;;; message.el --- composing mail and news messages
-;; Copyright (C) 1996-2000 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000
+;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: mail, news
:group 'message-forwarding
:type 'boolean)
+(defcustom message-forward-show-mml t
+ "*If non-nil, forward messages are shown as mml. Otherwise, forward messages are unchanged."
+ :group 'message-forwarding
+ :type 'boolean)
+
(defcustom message-forward-before-signature t
"*If non-nil, put forwarded message before signature, else after."
:group 'message-forwarding
"\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
"[:>|}].*")
(0 'message-cited-text-face))
- ("<#/?\\(multipart\\|part\\|external\\).*>"
+ ("<#/?\\(multipart\\|part\\|external\\|mml\\).*>"
(0 'message-mml-face))))
"Additional expressions to highlight in Message mode.")
mm-auto-save-coding-system
"Coding system to compose mail.")
+(defcustom message-send-mail-partially-limit 1000000
+ "The limitation of messages sent as message/partial.
+The lower bound of message size in characters, beyond which the message
+should be sent in several parts. If it is nil, the size is unlimited."
+ :group 'message-buffers
+ :type '(choice (const :tag "unlimited" nil)
+ (integer 1000000)))
+
;;; Internal variables.
(defvar message-buffer-list nil)
(insert (or (message-fetch-reply-field "reply-to")
(message-fetch-reply-field "from") "")))
+(defun message-widen-reply ()
+ "Widen the reply to include maximum recipients."
+ (interactive)
+ (let ((follow-to
+ (and message-reply-buffer
+ (buffer-name message-reply-buffer)
+ (save-excursion
+ (set-buffer message-reply-buffer)
+ (message-get-reply-headers t)))))
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (dolist (elem follow-to)
+ (message-remove-header (symbol-name (car elem)))
+ (goto-char (point-min))
+ (insert (symbol-name (car elem)) ": "
+ (cdr elem) "\n"))))))
+
(defun message-insert-newsgroups ()
"Insert the Newsgroups header from the article being replied to."
(interactive)
(eval (car actions)))))
(pop actions)))
+(defun message-send-mail-partially ()
+ "Sendmail as message/partial."
+ (let ((p (goto-char (point-min)))
+ (tembuf (message-generate-new-buffer-clone-locals " message temp"))
+ (curbuf (current-buffer))
+ (id (message-make-message-id)) (n 1)
+ plist total header required-mail-headers)
+ (while (not (eobp))
+ (if (< (point-max) (+ p message-send-mail-partially-limit))
+ (goto-char (point-max))
+ (goto-char (+ p message-send-mail-partially-limit))
+ (beginning-of-line)
+ (if (<= (point) p) (end-of-line))) ;; In case of bad message.
+ (push p plist)
+ (setq p (point)))
+ (setq total (length plist))
+ (push (point-max) plist)
+ (setq plist (nreverse plist))
+ (unwind-protect
+ (save-excursion
+ (setq p (pop plist))
+ (while plist
+ (set-buffer curbuf)
+ (copy-to-buffer tembuf p (car plist))
+ (set-buffer tembuf)
+ (goto-char (point-min))
+ (if header
+ (progn
+ (goto-char (point-min))
+ (narrow-to-region (point) (point))
+ (insert header))
+ (message-goto-eoh)
+ (setq header (buffer-substring (point-min) (point)))
+ (goto-char (point-min))
+ (narrow-to-region (point) (point))
+ (insert header)
+ (message-remove-header "Mime-Version")
+ (message-remove-header "Content-Type")
+ (message-remove-header "Message-ID")
+ (message-remove-header "Lines")
+ (goto-char (point-max))
+ (insert "Mime-Version: 1.0\n")
+ (setq header (buffer-substring (point-min) (point-max))))
+ (goto-char (point-max))
+ (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n"
+ id n total))
+ (let ((mail-header-separator ""))
+ (when (memq 'Message-ID message-required-mail-headers)
+ (insert "Message-ID: " (message-make-message-id) "\n"))
+ (when (memq 'Lines message-required-mail-headers)
+ (let ((mail-header-separator ""))
+ (insert "Lines: " (message-make-lines) "\n")))
+ (message-goto-subject)
+ (end-of-line)
+ (insert (format " (%d/%d)" n total))
+ (goto-char (point-max))
+ (insert "\n")
+ (widen)
+ (funcall message-send-mail-function))
+ (setq n (+ n 1))
+ (setq p (pop plist))
+ (erase-buffer)))
+ (kill-buffer tembuf))))
+
(defun message-send-mail (&optional arg)
(require 'mail-utils)
(let* ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
(or (message-fetch-field "cc")
(message-fetch-field "to")))
(message-insert-courtesy-copy))
- (funcall message-send-mail-function))
+ (if (or (not message-send-mail-partially-limit)
+ (< (point-max) message-send-mail-partially-limit)
+ (not (y-or-n-p "The message size is too large, should it be sent partially?")))
+ (funcall message-send-mail-function)
+ (message-send-mail-partially)))
(kill-buffer tembuf))
(set-buffer mailbuf)
(push 'mail message-sent-message-via)))
(message-setup `((Newsgroups . ,(or newsgroups ""))
(Subject . ,(or subject ""))))))
+(defun message-get-reply-headers (wide &optional to-address)
+ (let (follow-to mct never-mct from to cc reply-to ccalist)
+ ;; Find all relevant headers we need.
+ (setq from (message-fetch-field "from")
+ to (message-fetch-field "to")
+ cc (message-fetch-field "cc")
+ mct (message-fetch-field "mail-copies-to")
+ reply-to (message-fetch-field "reply-to"))
+
+ ;; Handle special values of Mail-Copies-To.
+ (when mct
+ (cond ((or (equal (downcase mct) "never")
+ (equal (downcase mct) "nobody"))
+ (setq never-mct t)
+ (setq mct nil))
+ ((or (equal (downcase mct) "always")
+ (equal (downcase mct) "poster"))
+ (setq mct (or reply-to from)))))
+
+ (if (or (not wide)
+ to-address)
+ (progn
+ (setq follow-to (list (cons 'To (or to-address reply-to from))))
+ (when (and wide mct)
+ (push (cons 'Cc mct) follow-to)))
+ (let (ccalist)
+ (save-excursion
+ (message-set-work-buffer)
+ (unless never-mct
+ (insert (or reply-to from "")))
+ (insert (if to (concat (if (bolp) "" ", ") to "") ""))
+ (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
+ (insert (if cc (concat (if (bolp) "" ", ") cc) ""))
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t]+" nil t)
+ (replace-match " " t t))
+ ;; Remove addresses that match `rmail-dont-reply-to-names'.
+ (let ((rmail-dont-reply-to-names message-dont-reply-to-names))
+ (insert (prog1 (rmail-dont-reply-to (buffer-string))
+ (erase-buffer))))
+ (goto-char (point-min))
+ ;; Perhaps "Mail-Copies-To: never" removed the only address?
+ (when (eobp)
+ (insert (or reply-to from "")))
+ (setq ccalist
+ (mapcar
+ (lambda (addr)
+ (cons (mail-strip-quoted-names addr) addr))
+ (message-tokenize-header (buffer-string))))
+ (let ((s ccalist))
+ (while s
+ (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
+ (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
+ (when ccalist
+ (let ((ccs (cons 'Cc (mapconcat
+ (lambda (addr) (cdr addr)) ccalist ", "))))
+ (when (string-match "^ +" (cdr ccs))
+ (setcdr ccs (substring (cdr ccs) (match-end 0))))
+ (push ccs follow-to)))))
+ follow-to))
+
+
;;;###autoload
(defun message-reply (&optional to-address wide)
"Start editing a reply to the article in the current buffer."
references message-id follow-to
(inhibit-point-motion-hooks t)
(message-this-is-mail t)
- mct never-mct gnus-warning)
+ gnus-warning)
(save-restriction
(message-narrow-to-head)
;; Allow customizations to have their say.
(save-excursion
(setq follow-to
(funcall message-wide-reply-to-function)))))
- ;; Find all relevant headers we need.
- (setq from (message-fetch-field "from")
- date (message-fetch-field "date")
- subject (or (message-fetch-field "subject") "none")
- to (message-fetch-field "to")
- cc (message-fetch-field "cc")
- mct (message-fetch-field "mail-copies-to")
- reply-to (message-fetch-field "reply-to")
+ (setq message-id (message-fetch-field "message-id" t)
references (message-fetch-field "references")
- message-id (message-fetch-field "message-id" t))
- ;; Remove any (buggy) Re:'s that are present and make a
- ;; proper one.
- (when (string-match message-subject-re-regexp subject)
- (setq subject (substring subject (match-end 0))))
- (setq subject (concat "Re: " subject))
-
- (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
- (string-match "<[^>]+>" gnus-warning))
- (setq message-id (match-string 0 gnus-warning)))
-
- ;; Handle special values of Mail-Copies-To.
- (when mct
- (cond ((or (equal (downcase mct) "never")
- (equal (downcase mct) "nobody"))
- (setq never-mct t)
- (setq mct nil))
- ((or (equal (downcase mct) "always")
- (equal (downcase mct) "poster"))
- (setq mct (or reply-to from)))))
-
- (unless follow-to
- (if (or (not wide)
- to-address)
- (progn
- (setq follow-to (list (cons 'To (or to-address reply-to from))))
- (when (and wide mct)
- (push (cons 'Cc mct) follow-to)))
- (let (ccalist)
- (save-excursion
- (message-set-work-buffer)
- (unless never-mct
- (insert (or reply-to from "")))
- (insert (if to (concat (if (bolp) "" ", ") to "") ""))
- (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
- (insert (if cc (concat (if (bolp) "" ", ") cc) ""))
- (goto-char (point-min))
- (while (re-search-forward "[ \t]+" nil t)
- (replace-match " " t t))
- ;; Remove addresses that match `rmail-dont-reply-to-names'.
- (let ((rmail-dont-reply-to-names message-dont-reply-to-names))
- (insert (prog1 (rmail-dont-reply-to (buffer-string))
- (erase-buffer))))
- (goto-char (point-min))
- ;; Perhaps Mail-Copies-To: never removed the only address?
- (when (eobp)
- (insert (or reply-to from "")))
- (setq ccalist
- (mapcar
- (lambda (addr)
- (cons (mail-strip-quoted-names addr) addr))
- (message-tokenize-header (buffer-string))))
- (let ((s ccalist))
- (while s
- (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
- (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
- (when ccalist
- (let ((ccs (cons 'Cc (mapconcat
- (lambda (addr) (cdr addr)) ccalist ", "))))
- (when (string-match "^ +" (cdr ccs))
- (setcdr ccs (substring (cdr ccs) (match-end 0))))
- (push ccs follow-to))))))
- (widen))
-
- (message-pop-to-buffer (message-buffer-name
- (if wide "wide reply" "reply") from
- (if wide to-address nil)))
+ date (message-fetch-field "date")
+ from (message-fetch-field "from")
+ subject (or (message-fetch-field "subject") "none"))
+ ;; Remove any (buggy) Re:'s that are present and make a
+ ;; proper one.
+ (when (string-match message-subject-re-regexp subject)
+ (setq subject (substring subject (match-end 0))))
+ (setq subject (concat "Re: " subject))
+
+ (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
+ (string-match "<[^>]+>" gnus-warning))
+ (setq message-id (match-string 0 gnus-warning)))
+
+ (unless follow-to
+ (setq follow-to (message-get-reply-headers wide to-address))))
+
+ (message-pop-to-buffer
+ (message-buffer-name
+ (if wide "wide reply" "reply") from
+ (if wide to-address nil)))
(setq message-reply-headers
(vector 0 subject from date message-id references 0 0 ""))
"Forward the current message via mail.
Optional NEWS will use news to forward instead of mail."
(interactive "P")
- (let ((cur (current-buffer))
- (subject (message-make-forward-subject))
- art-beg)
+ (let* ((cur (current-buffer))
+ (subject (if message-forward-show-mml
+ (message-make-forward-subject)
+ (mail-decode-encoded-word-string
+ (message-make-forward-subject))))
+ art-beg)
(if news
(message-news nil subject)
(message-mail nil subject))
(message-goto-body)
(goto-char (point-max)))
(if message-forward-as-mime
- (insert "\n\n<#part type=message/rfc822 disposition=inline>\n")
+ (if message-forward-show-mml
+ (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")
+ (insert "\n\n<#part type=message/rfc822 disposition=inline"
+ " buffer=\"" (buffer-name cur) "\">\n"))
(insert "\n-------------------- Start of forwarded message --------------------\n"))
(let ((b (point))
e)
- (mml-insert-buffer cur)
+ (if message-forward-show-mml
+ (insert-buffer-substring cur)
+ (unless message-forward-as-mime
+ (mml-insert-buffer cur)))
(setq e (point))
(if message-forward-as-mime
- (insert "<#/part>\n")
+ (if message-forward-show-mml
+ (insert "<#/mml>\n")
+ (insert "<#/part>\n"))
(insert "\n-------------------- End of forwarded message --------------------\n"))
- (when (and (not current-prefix-arg)
- message-forward-ignored-headers)
+ (when (and (or message-forward-show-mml
+ (not message-forward-as-mime))
+ (not current-prefix-arg)
+ message-forward-ignored-headers)
(save-restriction
(narrow-to-region b e)
(goto-char b)
projects / gnus / blobdiff