* message.el (message-send-mail-partially-limit): Change the default value.

[gnus] / lisp / message.el

diff --git a/lisp/message.el b/lisp/message.el
index 2bf52d2..db38623 100644 (file)
--- a/lisp/message.el
+++ b/lisp/message.el
@@ -1,5 +1,6 @@
 ;;; message.el --- composing mail and news messages
 ;;; 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
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: mail, news


@@ -298,6 +299,11 @@ The provided functions are:
   :group 'message-forwarding
   :type 'boolean)
 
   :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
 (defcustom message-forward-before-signature t
   "*If non-nil, put forwarded message before signature, else after."
   :group 'message-forwarding


@@ -843,7 +849,7 @@ Defaults to `text-mode-abbrev-table'.")
                "\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
                "[:>|}].*")
        (0 'message-cited-text-face))
                "\\([" 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.")
 
        (0 'message-mml-face))))
   "Additional expressions to highlight in Message mode.")
 


@@ -888,6 +894,14 @@ The cdr of ech entry is a function for applying the face to a region.")
   mm-auto-save-coding-system
   "Coding system to compose mail.")
 
   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)
 ;;; Internal variables.
 
 (defvar message-buffer-list nil)


@@ -1585,6 +1599,24 @@ With the prefix argument FORCE, insert the header anyway."
   (insert (or (message-fetch-reply-field "reply-to")
              (message-fetch-reply-field "from") "")))
 
   (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)
 (defun message-insert-newsgroups ()
   "Insert the Newsgroups header from the article being replied to."
   (interactive)


@@ -2127,6 +2159,70 @@ It should typically alter the sending method in some way or other."
        (eval (car actions)))))
     (pop actions)))
 
        (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"))
 (defun message-send-mail (&optional arg)
   (require 'mail-utils)
   (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp"))


@@ -2173,7 +2269,11 @@ It should typically alter the sending method in some way or other."
                     (or (message-fetch-field "cc")
                         (message-fetch-field "to")))
            (message-insert-courtesy-copy))
                     (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)))
       (kill-buffer tembuf))
     (set-buffer mailbuf)
     (push 'mail message-sent-message-via)))


@@ -3479,6 +3579,68 @@ OTHER-HEADERS is an alist of header/value pairs."
     (message-setup `((Newsgroups . ,(or newsgroups ""))
                     (Subject . ,(or subject ""))))))
 
     (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."
 ;;;###autoload
 (defun message-reply (&optional to-address wide)
   "Start editing a reply to the article in the current buffer."


@@ -3488,7 +3650,7 @@ OTHER-HEADERS is an alist of header/value pairs."
        references message-id follow-to
        (inhibit-point-motion-hooks t)
        (message-this-is-mail t)
        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-restriction
       (message-narrow-to-head)
       ;; Allow customizations to have their say.


@@ -3501,82 +3663,28 @@ OTHER-HEADERS is an alist of header/value pairs."
            (save-excursion
              (setq follow-to
                    (funcall message-wide-reply-to-function)))))
            (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")
            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 ""))
 
     (setq message-reply-headers
          (vector 0 subject from date message-id references 0 0 ""))


@@ -3894,9 +4002,12 @@ the message."
   "Forward the current message via mail.
 Optional NEWS will use news to forward instead of mail."
   (interactive "P")
   "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))
     (if news
        (message-news nil subject)
       (message-mail nil subject))


@@ -3906,17 +4017,27 @@ Optional NEWS will use news to forward instead of mail."
         (message-goto-body)
       (goto-char (point-max)))
     (if message-forward-as-mime
         (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)
       (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
       (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"))
        (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)
        (save-restriction
          (narrow-to-region b e)
          (goto-char b)