;;; 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 <larsi@ifi.uio.no>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile
+ (require 'cl)
+ (require 'smtp)
+ )
(require 'mailheader)
(require 'nnheader)
: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.
'(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
(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
: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."
: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.
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)
((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
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)
;; 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."
1 'message-separator-face)
(,(concat "^[ \t]*"
"\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
- "[>|}].*")
+ "[:>|}].*")
(0 'message-cited-text-face))))
"Additional expressions to highlight in Message mode.")
+;; XEmacs does it like this. For Emacs, we have to set the
+;; `font-lock-defaults' buffer-local variable.
(put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t))
(defvar message-face-alist
(Lines)
(Expires)
(Message-ID)
- (References)
+ (References . message-fill-references)
(X-Mailer)
(X-Newsreader))
"Alist used for formatting headers.")
(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 "\t" 'message-tab))
["Caesar (rot13) Region" message-caesar-region (mark t)]
["Elide Region" message-elide-region (mark t)]
["Delete Outside Region" message-delete-not-region (mark t)]
+ ["Kill To Signature" message-kill-to-signature t]
["Newline and Reformat" message-newline-and-reformat t]
["Rename buffer" message-rename-buffer t]
["Spellcheck" ispell-message t]
(mail-abbrevs-setup)
(funcall (intern "mail-aliases-setup"))))
(message-set-auto-save-file-name)
+ (unless (string-match "XEmacs" emacs-version)
+ (set (make-local-variable 'font-lock-defaults)
+ '(message-font-lock-keywords t)))
(run-hooks 'text-mode-hook 'message-mode-hook))
\f
(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)
+ (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."
(interactive)
(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)
(read-string "New buffer name: " name-default)
name-default))
(default-directory
- (file-name-as-directory message-autosave-directory)))
+ (if message-autosave-directory
+ (file-name-as-directory message-autosave-directory)
+ default-directory)))
(rename-buffer name t)))))
(defun message-fill-yanked-message (&optional justifyp)
(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))
(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)))
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))
(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)
(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)
;; 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)
(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)))))
(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)
(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))
": "
(set-buffer (get-buffer-create " *message resend*"))
(buffer-disable-undo (current-buffer))
(erase-buffer)
- (message-setup `((To . ,address)))
+ ;; avoid to turn-on-mime-edit
+ (let (message-setup-hook)
+ (message-setup `((To . ,address)))
+ )
;; Insert our usual headers.
(message-generate-headers '(From Date To))
(message-narrow-to-headers)
(when (looking-at "From ")
(replace-match "X-From-Line: "))
;; Send it.
- (message-send-mail)
+ (let ((message-encoding-buffer (current-buffer))
+ (message-edit-buffer (current-buffer)))
+ (message-send-mail))
(kill-buffer (current-buffer)))
(message "Resending message to %s...done" address)))
(defvar gnus-active-hashtb)
(defun message-expand-group ()
+ "Expand the group name under point."
(let* ((b (save-excursion
(save-restriction
(narrow-to-region
projects / elisp / gnus.git- / blobdiff