;;; 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>
-;; Keywords: mail, news
+;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Keywords: mail, news, MIME
;; This file is part of GNU Emacs.
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile
+ (require 'cl)
+ (require 'smtp)
+ )
(require 'mailheader)
-(condition-case nil
- (require 'rmail)
- (t (message "Ignore any errors about rmail from this file")))
(require 'nnheader)
(require 'timezone)
(require 'easymenu)
(if (string-match "XEmacs\\|Lucid" emacs-version)
(require 'mail-abbrevs)
(require 'mailabbrev))
+(require 'mime-edit)
(defgroup message '((user-mail-address custom-variable)
(user-full-name custom-variable))
(function :tag "Other"))
:group 'message-sending)
+(defcustom message-encode-function 'message-maybe-encode
+ "*A function called to encode messages."
+ :group 'message-sending
+ :type 'function)
+
(defcustom message-courtesy-message
"The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n"
"*This is inserted at the start of a mailed copy of a posted message.
: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.
:type 'file
:group 'message-headers)
-(defcustom message-autosave-directory
- (nnheader-concat message-directory "drafts/")
- "*Directory where Message autosaves buffers.
-If nil, Message won't autosave."
- :group 'message-buffers
- :type 'directory)
-
(defcustom message-forward-start-separator
- "------- Start of forwarded message -------\n"
+ (concat (mime-make-tag "message" "rfc822") "\n")
"*Delimiter inserted before forwarded messages."
:group 'message-forwarding
:type 'string)
(defcustom message-forward-end-separator
- "------- End of forwarded message -------\n"
+ ""
"*Delimiter inserted after forwarded messages."
:group 'message-forwarding
:type 'string)
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.
+Note that when posting from inside Gnus, for instance, this
+variable isn't used."
:group 'message-news
:group 'message-sending
;; This should be the `gnus-select-method' widget, but that might
:group 'message-headers
:type 'boolean)
-(defcustom message-setup-hook nil
+(defcustom message-setup-hook
+ '(message-maybe-setup-default-charset turn-on-mime-edit)
"Normal hook, run each time a new outgoing message is initialized.
The function `message-setup' runs this hook."
:group 'message-various
:group 'message-various
:type 'hook)
-(defcustom message-header-hook nil
+(defcustom message-header-hook '(eword-encode-header)
"Hook run in a message mode buffer narrowed to the headers."
:group 'message-various
: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)
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)
(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")
;; 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."
The default is `abbrev', which uses mailabbrev. nil switches
mail aliases off.")
+(defcustom message-autosave-directory
+ (nnheader-concat message-directory "drafts/")
+ "*Directory where Message autosaves buffers if Gnus isn't running.
+If nil, Message won't autosave."
+ :group 'message-buffers
+ :type 'directory)
+
;;; Internal variables.
;;; Well, not really internal.
(,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content)
(1 'message-header-name-face)
(2 'message-header-name-face))
- (,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
- 1 'message-separator-face)
+ ,@(if (and mail-header-separator
+ (not (equal mail-header-separator "")))
+ `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
+ 1 'message-separator-face))
+ nil)
(,(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
'((bold . bold-region)
(underline . underline-region)
(Lines)
(Expires)
(Message-ID)
- (References)
+ (References . message-fill-references)
(X-Mailer)
(X-Newsreader))
"Alist used for formatting headers.")
(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 'gnus-alive-p "gnus-util")
+ (autoload 'rmail-output "rmail"))
\f
(defun message-fetch-field (header &optional not-all)
"The same as `mail-fetch-field', only remove all newlines."
- (let ((value (mail-fetch-field header nil (not not-all))))
+ (let* ((inhibit-point-motion-hooks t)
+ (value (mail-fetch-field header nil (not not-all))))
(when value
(nnheader-replace-chars-in-string value ?\n ? ))))
(defun message-news-p ()
"Say whether the current buffer contains a news message."
- (or message-this-is-news
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (and (message-fetch-field "newsgroups")
- (not (message-fetch-field "posted-to")))))))
+ (and (not message-this-is-mail)
+ (or message-this-is-news
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (and (message-fetch-field "newsgroups")
+ (not (message-fetch-field "posted-to"))))))))
(defun message-mail-p ()
"Say whether the current buffer contains a mail message."
- (or message-this-is-mail
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (or (message-fetch-field "to")
- (message-fetch-field "cc")
- (message-fetch-field "bcc"))))))
+ (and (not message-this-is-news)
+ (or message-this-is-mail
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (or (message-fetch-field "to")
+ (message-fetch-field "cc")
+ (message-fetch-field "bcc")))))))
(defun message-next-header ()
"Go to the beginning of the next header."
(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]
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)
(setq major-mode 'message-mode)
(setq mode-name "Message")
(setq buffer-offer-save t)
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults '(message-font-lock-keywords t))
(make-local-variable 'facemenu-add-face-function)
(make-local-variable 'facemenu-remove-face-function)
(setq facemenu-add-face-function
(concat (regexp-quote mail-header-separator)
"$\\|[ \t]*[-_][-_][-_]+$\\|"
"-- $\\|"
- ;;!!! Uhm... shurely this can't be right.
+ ;;!!! Uhm... shurely this can't be right?
"[> " (regexp-quote message-yank-prefix) "]+$\\|"
paragraph-start))
(setq paragraph-separate
(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)))
+ (make-local-variable 'adaptive-fill-regexp)
+ (setq adaptive-fill-regexp
+ (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|" adaptive-fill-regexp))
+ (unless (boundp 'adaptive-fill-first-line-regexp)
+ (setq adaptive-fill-first-line-regexp nil))
+ (make-local-variable 'adaptive-fill-first-line-regexp)
+ (setq adaptive-fill-first-line-regexp
+ (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|"
+ adaptive-fill-first-line-regexp))
(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)
(name-default (concat "*message* " mail-trimmed-to))
(name (if enter-string
(read-string "New buffer name: " name-default)
- name-default))
- (default-directory
- (file-name-as-directory message-autosave-directory)))
+ name-default)))
(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))
(message-fix-before-sending)
(run-hooks 'message-send-hook)
(message "Sending...")
- (let ((alist message-send-method-alist)
+ (let ((message-encoding-buffer
+ (message-generate-new-buffer-clone-locals " message encoding"))
+ (message-edit-buffer (current-buffer))
+ (message-mime-mode mime-edit-mode-flag)
+ (alist message-send-method-alist)
(success t)
elem sent)
- (while (and success
- (setq elem (pop alist)))
- (when (and (or (not (funcall (cadr elem)))
- (and (or (not (memq (car elem)
- message-sent-message-via))
- (y-or-n-p
- (format
- "Already sent message via %s; resend? "
- (car elem))))
- (setq success (funcall (caddr elem) arg)))))
- (setq sent t)))
+ (save-excursion
+ (set-buffer message-encoding-buffer)
+ (erase-buffer)
+ (insert-buffer message-edit-buffer)
+ (funcall message-encode-function)
+ (while (and success
+ (setq elem (pop alist)))
+ (when (and (or (not (funcall (cadr elem)))
+ (and (or (not (memq (car elem)
+ message-sent-message-via))
+ (y-or-n-p
+ (format
+ "Already sent message via %s; resend? "
+ (car elem))))
+ (setq success (funcall (caddr elem) arg)))))
+ (setq sent t))))
(when (and success sent)
(message-do-fcc)
;;(when (fboundp 'mail-hist-put-headers-into-history)
(require 'mail-utils)
(let ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
(case-fold-search nil)
- (news (message-news-p))
- (message-buffer (current-buffer)))
+ (news (message-news-p)))
(save-restriction
(message-narrow-to-headers)
;; Insert some headers.
(save-excursion
(set-buffer tembuf)
(erase-buffer)
- ;; Avoid copying text props.
- ;; (insert (format
- ;; "%s" (save-excursion
- ;; (set-buffer message-buffer)
- ;; (buffer-string))))
- ;; 1997-09-29 by MORIOKA Tomohiko
- ;; Don't avoid text properties.
- (insert-buffer message-buffer)
+ (insert-buffer message-encoding-buffer)
;; Remove some headers.
(save-restriction
(message-narrow-to-headers)
(or (message-fetch-field "cc")
(message-fetch-field "to")))
(message-insert-courtesy-copy))
- ;; 1997-09-29 by MORIOKA Tomohiko
- (run-hooks 'message-encode-mail-hook)
+ (mime-edit-maybe-split-and-send
+ (function
+ (lambda ()
+ (interactive)
+ (funcall message-send-mail-function)
+ )))
(funcall message-send-mail-function))
(kill-buffer tembuf))
- (set-buffer message-buffer)
+ (set-buffer message-edit-buffer)
(push 'mail message-sent-message-via)))
(defun message-send-mail-with-sendmail ()
(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)
(method (if (message-functionp message-post-method)
(funcall message-post-method arg)
message-post-method))
- (message-buffer (current-buffer))
(message-syntax-checks
(if arg
(cons '(existing-newsgroups . disabled)
(set-buffer tembuf)
(buffer-disable-undo (current-buffer))
(erase-buffer)
- ;; Avoid copying text props.
- ;; (insert (format
- ;; "%s" (save-excursion
- ;; (set-buffer message-buffer)
- ;; (buffer-string))))
- ;; 1997-09-29 by MORIOKA Tomohiko
- ;; Don't avoid text properties.
- (insert-buffer message-buffer)
+ (insert-buffer message-encoding-buffer)
;; Remove some headers.
(save-restriction
(message-narrow-to-headers)
;; require one newline at the end.
(or (= (preceding-char) ?\n)
(insert ?\n))
- ;; 1997-09-29 by MORIOKA Tomohiko
- (run-hooks 'message-encode-news-hook)
+ (mime-edit-maybe-split-and-send
+ (function
+ (lambda ()
+ (interactive)
+ (save-restriction
+ (std11-narrow-to-header mail-header-separator)
+ (goto-char (point-min))
+ (when (re-search-forward "^Message-Id:" nil t)
+ (delete-region (match-end 0)(std11-field-end))
+ (insert (concat " " (message-make-message-id)))
+ ))
+ (funcall message-send-news-function method)
+ )))
(setq result (funcall message-send-news-function method)))
(kill-buffer tembuf))
- (set-buffer message-buffer)
+ (set-buffer message-edit-buffer)
(if result
(push 'news message-sent-message-via)
(message "Couldn't send message via news: %s"
(message-narrow-to-headers)
(message-check-news-header-syntax)))
;; Check the body.
- (message-check-news-body-syntax)))))
+ (save-excursion
+ (set-buffer message-edit-buffer)
+ (message-check-news-body-syntax))))))
(defun message-check-news-header-syntax ()
(and
(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)))))
nil)
(t t))))))
-(defconst message-max-size 60000)
-
(defun message-check-news-body-syntax ()
(and
;; Check for long lines.
(defun message-do-fcc ()
"Process Fcc headers in the current buffer."
(let ((case-fold-search t)
- (buf (current-buffer))
(coding-system-for-write 'raw-text)
list file)
(save-excursion
(set-buffer (get-buffer-create " *message temp*"))
(buffer-disable-undo (current-buffer))
(erase-buffer)
- (insert-buffer-substring buf)
+ (insert-buffer-substring message-encoding-buffer)
(save-restriction
(message-narrow-to-headers)
(while (setq file (message-fetch-field "fcc"))
(push file list)
(message-remove-header "fcc" nil t)))
- (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)
(when from
(let ((stop-pos
(string-match " *at \\| *@ \\| *(\\| *<" from)))
- (concat (if stop-pos (substring from 0 stop-pos) from)
+ (concat (if (and stop-pos
+ (not (zerop stop-pos)))
+ (substring from 0 stop-pos) from)
"'s message of \""
(if (or (not date) (string= date ""))
"(unknown date)" date)
(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 ()
(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))
": "
(defun message-set-auto-save-file-name ()
"Associate the message buffer with a file in the drafts directory."
(when message-autosave-directory
- (setq message-draft-article (nndraft-request-associate-buffer "drafts"))
+ (if (gnus-alive-p)
+ (setq message-draft-article
+ (nndraft-request-associate-buffer "drafts"))
+ (setq buffer-file-name (expand-file-name "*message*"
+ message-autosave-directory))
+ (setq buffer-auto-save-file-name (make-auto-save-file-name)))
(clear-visited-file-modtime)))
(defun message-disassociate-draft ()
(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 (mail-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.
message-cancel-message)
(message "Canceling your article...")
(if (let ((message-syntax-checks
- 'dont-check-for-anything-just-trust-me))
+ 'dont-check-for-anything-just-trust-me)
+ (message-encoding-buffer (current-buffer))
+ (message-edit-buffer (current-buffer)))
(message-send-news))
(message "Canceling your article...done"))
(kill-buffer buf)))))
(let ((cur (current-buffer)))
;; Check whether the user owns the article that is to be superseded.
(unless (string-equal
- (downcase (cadr (mail-extract-address-components
- (message-fetch-field "from"))))
- (downcase (message-make-address)))
+ (downcase (or (message-fetch-field "sender")
+ (cadr (mail-extract-address-components
+ (message-fetch-field "from")))))
+ (downcase (message-make-sender)))
(error "This article is not yours"))
;; Get a normal message buffer.
(message-pop-to-buffer (message-buffer-name "supersede"))
(concat "[" (or (message-fetch-field
(if (message-news-p) "newsgroups" "from"))
"(nowhere)")
- "] " (or (message-fetch-field "Subject") "")))))
+ "] " (or (eword-decode-unstructured-field-body
+ (message-fetch-field "Subject") ""))))))
;;;###autoload
(defun message-forward (&optional news)
(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)
(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.
(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
(point))
(skip-chars-backward "^, \t\n") (point))))
(completion-ignore-case t)
- (string (buffer-substring b (point)))
+ (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))
(cur (current-buffer))
(cdr local)))))
locals)))
+
+;;; @ for MIME Edit mode
+;;;
+
+(defun message-maybe-setup-default-charset ()
+ (let ((charset
+ (and (boundp 'gnus-summary-buffer)
+ (buffer-live-p gnus-summary-buffer)
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ default-mime-charset))))
+ (if charset
+ (progn
+ (make-local-variable 'default-mime-charset)
+ (setq default-mime-charset charset)
+ ))))
+
+(defun message-maybe-encode ()
+ (when message-mime-mode
+ (run-hooks 'mime-edit-translate-hook)
+ (if (catch 'mime-edit-error
+ (save-excursion
+ (mime-edit-translate-body)
+ ))
+ (error "Translation error!")
+ )
+ (end-of-invisible)
+ (run-hooks 'mime-edit-exit-hook)
+ ))
+
+(defun message-mime-insert-article (&optional message)
+ (interactive)
+ (let ((message-cite-function 'mime-edit-inserted-message-filter)
+ (message-reply-buffer gnus-original-article-buffer)
+ )
+ (message-yank-original nil)
+ ))
+
+(set-alist 'mime-edit-message-inserter-alist
+ 'message-mode (function message-mime-insert-article))
+
;;; Miscellaneous functions
;; stolen (and renamed) from nnheader.el
projects / elisp / gnus.git- / blobdiff