X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=2bb0627c737ece1d9ac4d5806d149e00c06c3a41;hb=e6c591b33a7f48a9585956761eeb88f8f29243a5;hp=b6f199f8f3f58a8e38816915923d99859b7cb520;hpb=bd38b7e5229f66edaede4061030bc7d11edba089;p=elisp%2Fgnus.git- diff --git a/lisp/message.el b/lisp/message.el index b6f199f..2bb0627 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,10 +332,12 @@ 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) + (function-item message-send-mail-with-smtp) (function :tag "Other")) :group 'message-sending :group 'message-mail) @@ -408,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 @@ -475,8 +482,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) @@ -590,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." @@ -779,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.") @@ -907,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.") @@ -1320,10 +1330,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)) @@ -1457,7 +1467,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." @@ -1513,8 +1527,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) @@ -1696,6 +1711,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)) @@ -1790,6 +1825,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))) @@ -1822,15 +1859,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)) @@ -1982,7 +2013,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) @@ -2030,27 +2062,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) @@ -2077,6 +2110,145 @@ to find out how to use this." ;; Pass it on to mh. (mh-send-letter))) +(defun message-send-mail-with-smtp () + "Send the prepared message buffer with SMTP." + (require 'smtp) + (let ((errbuf (if mail-interactive + (generate-new-buffer " smtp errors") + 0)) + (case-fold-search nil) + resend-to-addresses + delimline) + (unwind-protect + (save-excursion + (goto-char (point-max)) + ;; require one newline at the end. + (or (= (preceding-char) ?\n) + (insert ?\n)) + ;; Change header-delimiter to be what sendmail expects. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (backward-char 1) + (setq delimline (point-marker)) + (run-hooks 'message-send-mail-hook) + ;; (sendmail-synch-aliases) + ;; (if mail-aliases + ;; (expand-mail-aliases (point-min) delimline)) + (goto-char (point-min)) + ;; ignore any blank lines in the header + (while (and (re-search-forward "\n\n\n*" delimline t) + (< (point) delimline)) + (replace-match "\n")) + (let ((case-fold-search t)) + (goto-char (point-min)) + (goto-char (point-min)) + (while (re-search-forward "^Resent-to:" delimline t) + (setq resend-to-addresses + (save-restriction + (narrow-to-region (point) + (save-excursion + (end-of-line) + (point))) + (append (mail-parse-comma-list) + resend-to-addresses)))) +;;; Apparently this causes a duplicate Sender. +;;; ;; If the From is different than current user, insert Sender. +;;; (goto-char (point-min)) +;;; (and (re-search-forward "^From:" delimline t) +;;; (progn +;;; (require 'mail-utils) +;;; (not (string-equal +;;; (mail-strip-quoted-names +;;; (save-restriction +;;; (narrow-to-region (point-min) delimline) +;;; (mail-fetch-field "From"))) +;;; (user-login-name)))) +;;; (progn +;;; (forward-line 1) +;;; (insert "Sender: " (user-login-name) "\n"))) + ;; Don't send out a blank subject line + (goto-char (point-min)) + (if (re-search-forward "^Subject:[ \t]*\n" delimline t) + (replace-match "")) + ;; Put the "From:" field in unless for some odd reason + ;; they put one in themselves. + (goto-char (point-min)) + (if (not (re-search-forward "^From:" delimline t)) + (let* ((login user-mail-address) + (fullname (user-full-name))) + (cond ((eq mail-from-style 'angles) + (insert "From: " fullname) + (let ((fullname-start (+ (point-min) 6)) + (fullname-end (point-marker))) + (goto-char fullname-start) + ;; Look for a character that cannot appear unquoted + ;; according to RFC 822. + (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" + fullname-end 1) + (progn + ;; Quote fullname, escaping specials. + (goto-char fullname-start) + (insert "\"") + (while (re-search-forward "[\"\\]" + fullname-end 1) + (replace-match "\\\\\\&" t)) + (insert "\"")))) + (insert " <" login ">\n")) + ((eq mail-from-style 'parens) + (insert "From: " login " (") + (let ((fullname-start (point))) + (insert fullname) + (let ((fullname-end (point-marker))) + (goto-char fullname-start) + ;; RFC 822 says \ and nonmatching parentheses + ;; must be escaped in comments. + ;; Escape every instance of ()\ ... + (while (re-search-forward "[()\\]" fullname-end 1) + (replace-match "\\\\\\&" t)) + ;; ... then undo escaping of matching parentheses, + ;; including matching nested parentheses. + (goto-char fullname-start) + (while (re-search-forward + "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" + fullname-end 1) + (replace-match "\\1(\\3)" t) + (goto-char fullname-start)))) + (insert ")\n")) + ((null mail-from-style) + (insert "From: " login "\n"))))) + ;; Insert an extra newline if we need it to work around + ;; Sun's bug that swallows newlines. + (goto-char (1+ delimline)) + (if (eval mail-mailer-swallows-blank-line) + (newline)) + ;; Find and handle any FCC fields. + (goto-char (point-min)) + (if (re-search-forward "^FCC:" delimline t) + (mail-do-fcc delimline)) + (if mail-interactive + (save-excursion + (set-buffer errbuf) + (erase-buffer)))) + ;; + ;; + ;; + (let ((recipient-address-list + (or resend-to-addresses + (smtp-deduce-address-list (current-buffer) + (point-min) delimline)))) + (smtp-do-bcc delimline) + + (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")) + )) + (if (bufferp errbuf) + (kill-buffer errbuf))))) + (defun message-send-news (&optional arg) (let ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) (case-fold-search nil) @@ -2274,8 +2446,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))))) @@ -2461,8 +2637,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) @@ -2955,9 +3130,19 @@ Headers already prepared in the buffer are not modified." (widen) (forward-line 1))) +(defun message-fill-references (header value) + (let ((begin (point)) + (fill-column 990) + (fill-prefix "\t")) + (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)) ": " @@ -3724,6 +3909,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