X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=ead854d769367bb7765d508e1b36ccf940bff317;hb=cddb4672a1b8d0b3fb03dd1c5cad4b01f9fab219;hp=650647d0929c4582ac8440ab339733b348aac6d4;hpb=870822142dbdbf720ada0e93c8f0649bbac1bd16;p=elisp%2Fgnus.git- diff --git a/lisp/message.el b/lisp/message.el index 650647d..ead854d 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -1,12 +1,13 @@ ;;; message.el --- composing mail and news messages -;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko ;; Shuhei KOBAYASHI -;; Keiichi Suzuki +;; Keiichi Suzuki ;; Tatsuya Ichikawa -;; Katsumi Yamaoka +;; Katsumi Yamaoka +;; Kiyokazu SUTO ;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -48,6 +49,14 @@ (require 'mailabbrev)) (require 'mime-edit) +;; Avoid byte-compile warnings. +(eval-when-compile + (require 'mail-parse) + (require 'mm-bodies) + (require 'mm-encode) + (require 'mml) + ) + (defgroup message '((user-mail-address custom-variable) (user-full-name custom-variable)) "Mail and news message composing." @@ -139,6 +148,11 @@ mailbox format." :group 'message-sending :type 'function) +(defcustom message-8bit-encoding-list '(8bit binary) + "*8bit encoding type in Content-Transfer-Encoding field." + :group 'message-sending + :type '(repeat (symbol :tag "Type"))) + (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. @@ -153,6 +167,11 @@ If this variable is nil, no such courtesy message will be added." :group 'message-interface :type 'regexp) +(defcustom message-bounce-setup-function 'message-bounce-setup-for-mime-edit + "Function to setup a re-sending bounced message." + :group 'message-sending + :type 'function) + ;;;###autoload (defcustom message-from-style 'default "*Specifies how \"From\" headers look. @@ -234,6 +253,12 @@ any confusion." :group 'message-interface :type 'regexp) +(defcustom message-supersede-setup-function + 'message-supersede-setup-for-mime-edit + "Function to setup a supersede message." + :group 'message-sending + :type 'function) + (defcustom message-subject-re-regexp "^[ \t]*\\([Rr][Ee]:[ \t]*\\)*[ \t]*" "*Regexp matching \"Re: \" in the subject line." :group 'message-various @@ -298,14 +323,15 @@ nil means let mailer mail back a message to report errors." :group 'message-mail :type 'boolean) -(defcustom message-generate-new-buffers t +(defcustom message-generate-new-buffers 'unique "*Non-nil means that a new message buffer will be created whenever `message-setup' is called. If this is a function, call that function with three parameters: The type, the to address and the group name. (Any of these may be nil.) The function should return the new buffer name." :group 'message-buffers :type '(choice (const :tag "off" nil) - (const :tag "on" t) + (const :tag "unique" unique) + (const :tag "unsent" unsent) (function fun))) (defcustom message-kill-buffer-on-exit nil @@ -364,7 +390,7 @@ If t, use `message-user-organization-file'." :group 'message-forwarding :type 'regexp) -(defcustom message-make-forward-subject-function +(defcustom message-make-forward-subject-function 'message-forward-subject-author-subject "*A list of functions that are called to generate a subject header for forwarded messages. The subject generated by the previous function is passed into each @@ -385,7 +411,7 @@ The provided functions are: :group 'message-forwarding :type 'boolean) -(defcustom message-ignored-resent-headers "^Return-Receipt" +(defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:" "*All headers that match this regexp will be deleted when resending a message." :group 'message-interface :type 'regexp) @@ -407,7 +433,7 @@ The provided functions are: 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), +Valid values include `message-send-mail-with-sendmail' (the default), `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) @@ -549,6 +575,11 @@ The function `message-setup' runs this hook." :group 'message-various :type 'hook) +(defcustom message-cancel-hook nil + "Hook run when cancelling articles." + :group 'message-various + :type 'hook) + (defcustom message-signature-setup-hook nil "Normal hook, run each time a new outgoing message is initialized. It is run after the headers have been inserted and before @@ -556,6 +587,18 @@ the signature is inserted." :group 'message-various :type 'hook) +(defcustom message-bounce-setup-hook nil + "Normal hook, run each time a re-sending bounced message is initialized. +The function `message-bounce' runs this hook." + :group 'message-various + :type 'hook) + +(defcustom message-supersede-setup-hook nil + "Normal hook, run each time a supersede message is initialized. +The function `message-supersede' runs this hook." + :group 'message-various + :type 'hook) + (defcustom message-mode-hook nil "Hook run in message mode buffers." :group 'message-various @@ -579,11 +622,16 @@ the signature is inserted." ;;;###autoload (defcustom message-yank-prefix "> " - "*Prefix inserted on the lines of yanked messages. -nil means use indentation." + "*Prefix inserted on the lines of yanked messages." :type 'string :group 'message-insertion) +(defcustom message-yank-add-new-references t + "*Non-nil means new IDs will be added to \"References\" field when an +article is yanked by the command `message-yank-original' interactively." + :type 'boolean + :group 'message-insertion) + (defcustom message-indentation-spaces 3 "*Number of spaces to insert at the beginning of each cited line. Used by `message-yank-original' via `message-yank-cite'." @@ -597,6 +645,7 @@ Predefined functions include `message-cite-original' and `message-cite-original-without-signature'. Note that `message-cite-original' uses `mail-citation-hook' if that is non-nil." :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) @@ -726,11 +775,10 @@ actually occur." ;; Ignore errors in case this is used in Emacs 19. ;; Don't use ignore-errors because this is copied into loaddefs.el. ;;;###autoload -(condition-case nil - (define-mail-user-agent 'message-user-agent - 'message-mail 'message-send-and-exit - 'message-kill-buffer 'message-send-hook) - (error nil)) +(ignore-errors + (define-mail-user-agent 'message-user-agent + 'message-mail 'message-send-and-exit + 'message-kill-buffer 'message-send-hook)) (defvar message-mh-deletable-headers '(Message-ID Date Lines Sender) "If non-nil, delete the deletable headers before feeding to mh.") @@ -761,12 +809,26 @@ If nil, Message won't auto-save." :group 'message-buffers :type 'directory) +(defcustom message-buffer-naming-style 'unique + "*The way new message buffers are named. +Valid valued are `unique' and `unsent'." + :group 'message-buffers + :type '(choice (const :tag "unique" unique) + (const :tag "unsent" unsent))) + +(defcustom message-default-charset nil + "Default charset used in non-MULE XEmacsen." + :group 'message + :type 'symbol) + ;;; Internal variables. ;;; Well, not really internal. (defvar message-mode-syntax-table (let ((table (copy-syntax-table text-mode-syntax-table))) (modify-syntax-entry ?% ". " table) + (modify-syntax-entry ?> ". " table) + (modify-syntax-entry ?< ". " table) table) "Syntax table used while in Message mode.") @@ -886,6 +948,18 @@ Defaults to `text-mode-abbrev-table'.") "Face used for displaying cited text names." :group 'message-faces) +(defface message-mml-face + '((((class color) + (background dark)) + (:foreground "ForestGreen")) + (((class color) + (background light)) + (:foreground "ForestGreen")) + (t + (:bold t))) + "Face used for displaying MML." + :group 'message-faces) + (defvar message-font-lock-keywords (let* ((cite-prefix "A-Za-z") (cite-suffix (concat cite-prefix "0-9_.@-")) @@ -919,7 +993,9 @@ Defaults to `text-mode-abbrev-table'.") (,(concat "^[ \t]*" "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" "[:>|}].*") - (0 'message-cited-text-face)))) + (0 'message-cited-text-face)) + ("<#/?\\(multipart\\|part\\|external\\).*>" + (0 'message-mml-face)))) "Additional expressions to highlight in Message mode.") ;; XEmacs does it like this. For Emacs, we have to set the @@ -968,16 +1044,23 @@ The cdr of ech entry is a function for applying the face to a region.") (const :tag "always" t) (const :tag "ask" ask))) -(defvar message-send-coding-system 'binary - "Coding system to encode outgoing mail.") +(defvar message-draft-coding-system + (cond + ((not (fboundp 'find-coding-system)) nil) + ((find-coding-system 'emacs-mule) 'emacs-mule) + ((find-coding-system 'escape-quoted) 'escape-quoted) + ((find-coding-system 'no-conversion) 'no-conversion) + (t nil)) + "Coding system to compose mail.") ;;; Internal variables. -(defvar message-default-charset nil) (defvar message-buffer-list nil) (defvar message-this-is-news nil) (defvar message-this-is-mail nil) (defvar message-draft-article nil) +(defvar message-mime-part nil) +(defvar message-posting-charset nil) ;; Byte-compiler warning (defvar gnus-active-hashtb) @@ -1062,7 +1145,7 @@ The cdr of ech entry is a function for applying the face to a region.") (Lines) (Expires) (Message-ID) - (References . message-fill-header) + (References . message-shorten-references) (User-Agent)) "Alist used for formatting headers.") @@ -1087,6 +1170,22 @@ The cdr of ech entry is a function for applying the face to a region.") ;;; ;;; Utility functions. ;;; +(defun message-eval-parameter (parameter) + (condition-case () + (if (symbolp parameter) + (if (functionp parameter) + (funcall parameter) + (eval parameter)) + parameter) + (error nil))) + +(defsubst message-get-parameter (key &optional alist) + (unless alist + (setq alist message-parameter-alist)) + (cdr (assq key alist))) + +(defmacro message-get-parameter-with-eval (key &optional alist) + `(message-eval-parameter (message-get-parameter ,key ,alist))) (defmacro message-y-or-n-p (question show &rest text) "Ask QUESTION, displaying the rest of the arguments in a temp. buffer if SHOW" @@ -1121,12 +1220,12 @@ The cdr of ech entry is a function for applying the face to a region.") (not paren)))) (push (buffer-substring beg (point)) elems) (setq beg (match-end 0))) - ((= (following-char) ?\") + ((eq (char-after) ?\") (setq quoted (not quoted))) - ((and (= (following-char) ?\() + ((and (eq (char-after) ?\() (not quoted)) (setq paren t)) - ((and (= (following-char) ?\)) + ((and (eq (char-after) ?\)) (not quoted)) (setq paren nil)))) (nreverse elems))))) @@ -1148,7 +1247,8 @@ The cdr of ech entry is a function for applying the face to a region.") (when value (while (string-match "\n[\t ]+" value) (setq value (replace-match " " t t value))) - value))) + ;; We remove all text props.delete-region + (format "%s" value)))) (defun message-narrow-to-field () "Narrow the buffer to the header on the current line." @@ -1179,7 +1279,7 @@ The cdr of ech entry is a function for applying the face to a region.") (defun message-fetch-reply-field (header) "Fetch FIELD from the message we're replying to." - (let ((buffer (message-get-reply-buffer))) + (let ((buffer (message-eval-parameter message-reply-buffer))) (when (and buffer (buffer-name buffer)) (save-excursion @@ -1237,9 +1337,21 @@ Return the number of headers removed." (forward-line 1) (if (re-search-forward "^[^ \t]" nil t) (goto-char (match-beginning 0)) - (point-max)))) + (goto-char (point-max))))) number)) +(defun message-remove-first-header (header) + "Remove the first instance of HEADER if there is more than one." + (let ((count 0) + (regexp (concat "^" (regexp-quote header) ":"))) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (incf count))) + (while (> count 1) + (message-remove-header header nil t) + (decf count)))) + (defun message-narrow-to-headers () "Narrow the buffer to the head of the message." (widen) @@ -1309,6 +1421,7 @@ Point is left at the beginning of the narrowed-to region." (defun message-sort-headers-1 () "Sort the buffer as headers using `message-rank' text props." (goto-char (point-min)) + (require 'sort) (sort-subr nil 'message-next-header (lambda () @@ -1340,22 +1453,6 @@ Point is left at the beginning of the narrowed-to region." (1+ max))))) (message-sort-headers-1)))) -(defun message-eval-parameter (parameter) - (condition-case () - (if (symbolp parameter) - (if (functionp parameter) - (funcall parameter) - (eval parameter)) - parameter) - (error nil))) - -(defun message-get-reply-buffer () - (message-eval-parameter message-reply-buffer)) - -(defun message-get-original-reply-buffer () - (message-eval-parameter - (cdr (assq 'original-buffer message-parameter-alist)))) - ;;; @@ -1393,6 +1490,7 @@ Point is left at the beginning of the narrowed-to region." (define-key message-mode-map "\C-c\C-y" 'message-yank-original) (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message) (define-key message-mode-map "\C-c\C-w" 'message-insert-signature) + (define-key message-mode-map "\C-c\M-h" 'message-insert-headers) (define-key message-mode-map "\C-c\C-r" 'message-caesar-buffer-body) (define-key message-mode-map "\C-c\C-o" 'message-sort-headers) (define-key message-mode-map "\C-c\M-r" 'message-rename-buffer) @@ -1410,7 +1508,7 @@ Point is left at the beginning of the narrowed-to region." (define-key message-mode-map "\t" 'message-tab) (define-key message-mode-map "\C-x\C-s" 'message-save-drafts) - (define-key message-mode-map "\C-xk" 'message-kill-buffer)) + (define-key message-mode-map "\C-xk" 'message-mimic-kill-buffer)) (easy-menu-define message-mode-menu message-mode-map "Message Menu." @@ -1427,6 +1525,7 @@ Point is left at the beginning of the narrowed-to region." ["Newline and Reformat" message-newline-and-reformat t] ["Rename buffer" message-rename-buffer t] ["Spellcheck" ispell-message t] + ["Attach file as MIME" mime-edit-insert-file t] "----" ["Send Message" message-send-and-exit t] ["Abort Message" message-dont-send t] @@ -1482,10 +1581,9 @@ 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) - (make-local-variable 'message-reply-buffer) - (setq message-reply-buffer nil) - (make-local-variable 'message-send-actions) - (make-local-variable 'message-exit-actions) + (set (make-local-variable 'message-reply-buffer) nil) + (make-local-variable 'message-send-actions) + (make-local-variable 'message-exit-actions) (make-local-variable 'message-kill-actions) (make-local-variable 'message-postpone-actions) (make-local-variable 'message-draft-article) @@ -1524,10 +1622,8 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (setq message-reply-headers nil) (make-local-variable 'message-user-agent) (make-local-variable 'message-post-method) - (make-local-variable 'message-sent-message-via) - (setq message-sent-message-via nil) - (make-local-variable 'message-checksum) - (setq message-checksum nil) + (set (make-local-variable 'message-sent-message-via) nil) + (set (make-local-variable 'message-checksum) nil) (make-local-variable 'message-parameter-alist) (setq message-parameter-alist (copy-sequence message-startup-parameter-alist)) @@ -1555,6 +1651,8 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (setq adaptive-fill-first-line-regexp (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|" adaptive-fill-first-line-regexp)) + (make-local-variable 'indent-tabs-mode) ;Turn off tabs for indentation. + (setq indent-tabs-mode nil) (run-hooks 'text-mode-hook 'message-mode-hook)) @@ -1640,7 +1738,8 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (interactive) (if (looking-at "[ \t]*\n") (expand-abbrev)) (goto-char (point-min)) - (search-forward (concat "\n" mail-header-separator "\n") nil t)) + (or (search-forward (concat "\n" mail-header-separator "\n") nil t) + (search-forward "\n\n" nil t))) (defun message-goto-eoh () "Move point to the end of the headers." @@ -1745,8 +1844,7 @@ With the prefix argument FORCE, insert the header anyway." (eq force 0)) (save-excursion (goto-char (point-max)) - (not (re-search-backward - message-signature-separator nil t)))) + (not (re-search-backward message-signature-separator nil t)))) ((and (null message-signature) force) t) @@ -1933,6 +2031,28 @@ However, if `message-yank-prefix' is non-nil, insert that prefix on each line." (forward-line 1)))) (goto-char start))) +(defun message-list-references (refs-list &rest refs-strs) + "Add `Message-ID's which appear in REFS-STRS but not in REFS-LIST, +to REFS-LIST." + (let (refs ref id) + (while refs-strs + (setq refs (car refs-strs) + refs-strs (cdr refs-strs)) + (when refs + (setq refs (std11-parse-msg-ids (std11-lexical-analyze refs))) + (while refs + (setq ref (car refs) + refs (cdr refs)) + (when (eq (car ref) 'msg-id) + (setq id (concat "<" + (mapconcat + (function (lambda (p) (cdr p))) + (cdr ref) "") + ">")) + (or (member id refs-list) + (push id refs-list)))))) + refs-list)) + (defvar gnus-article-copy) (defun message-yank-original (&optional arg) "Insert the message being replied to, if any. @@ -1943,14 +2063,52 @@ if `message-yank-prefix' is non-nil, insert that prefix on each line. This function uses `message-cite-function' to do the actual citing. Just \\[universal-argument] as argument means don't indent, insert no -prefix, and don't delete any headers." +prefix, and don't delete any headers. + +In addition, if `message-yank-add-new-references' is non-nil and this +command is called interactively, new IDs from the yanked article will +be added to \"References\" field." (interactive "P") (let ((modified (buffer-modified-p)) - (buffer (message-get-reply-buffer))) + (buffer (message-eval-parameter message-reply-buffer)) + start end refs) (when (and buffer message-cite-function) (delete-windows-on buffer t) - (insert-buffer buffer) + (insert-buffer buffer) ; mark will be set at the end of article. + (setq start (point) + end (mark t)) + + ;; Add new IDs to References field. + (when (and message-yank-add-new-references (interactive-p)) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (setq refs (message-list-references + nil + (message-fetch-field "References"))) + (widen) + (narrow-to-region start end) + (std11-narrow-to-header) + (when (setq refs (message-list-references + refs + (or (message-fetch-field "References") + (message-fetch-field "In-Reply-To")) + (message-fetch-field "Message-ID"))) + (widen) + (message-narrow-to-headers) + (goto-char (point-min)) + (let ((case-fold-search t)) + (if (re-search-forward "^References:\\([\t ]+.+\n\\)+" nil t) + (replace-match "") + (goto-char (point-max)))) + (mail-header-format + (list (or (assq 'References message-header-format-alist) + '(References . message-fill-references))) + (list (cons 'References + (mapconcat 'identity (nreverse refs) " ")))) + (backward-delete-char 1))))) + (funcall message-cite-function) (message-exchange-point-and-mark) (unless (bolp) @@ -1968,7 +2126,7 @@ prefix, and don't delete any headers." message-indent-citation-function (list message-indent-citation-function))))) (goto-char end) - (when (re-search-backward "^-- $" start t) + (when (re-search-backward message-signature-separator start t) ;; Also peel off any blank lines before the signature. (forward-line -1) (while (looking-at "^[ \t]*$") @@ -1983,13 +2141,14 @@ prefix, and don't delete any headers." (insert "\n")) (funcall message-citation-line-function)))) -(defvar mail-citation-hook) ;Compiler directive +(defvar mail-citation-hook) ;Compiler directive (defun message-cite-original () "Cite function in the standard Message manner." (if (and (boundp 'mail-citation-hook) mail-citation-hook) (run-hooks 'mail-citation-hook) (let ((start (point)) + (end (mark t)) (functions (when message-indent-citation-function (if (listp message-indent-citation-function) @@ -2090,11 +2249,13 @@ 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-save-drafts) + (let ((actions message-postpone-actions) + (frame (selected-frame)) + (org-frame message-original-frame)) (message-bury (current-buffer)) - (message-do-actions actions))) + (message-do-actions actions) + (message-delete-frame frame org-frame))) (defun message-kill-buffer () "Kill the current buffer." @@ -2112,6 +2273,20 @@ The text will also be indented the normal way." (message-delete-frame frame org-frame))) (message "")) +(defun message-mimic-kill-buffer () + "Kill the current buffer with query." + (interactive) + (unless (eq 'message-mode major-mode) + (error "%s must be invoked from a message buffer." this-command)) + (let ((command this-command) + (bufname (read-buffer (format "Kill buffer: (default %s) " + (buffer-name))))) + (if (or (not bufname) + (string-equal bufname "") + (string-equal bufname (buffer-name))) + (message-kill-buffer) + (message "%s must be invoked only for the current buffer." command)))) + (defun message-delete-frame (frame org-frame) "Delete frame for editing message." (when (and (or (and (featurep 'xemacs) @@ -2182,21 +2357,24 @@ the user from the mailer." (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) - ;; (mail-hist-put-headers-into-history)) - (run-hooks 'message-sent-hook) - (message "Sending...done") - ;; Mark the buffer as unmodified and delete autosave. - (set-buffer-modified-p nil) - (delete-auto-save-file-if-necessary t) - (message-disassociate-draft) - ;; Delete other mail buffers and stuff. - (message-do-send-housekeeping) - (message-do-actions message-send-actions) - ;; Return success. - t)))) + (prog1 + (when (and success sent) + (message-do-fcc) + ;;(when (fboundp 'mail-hist-put-headers-into-history) + ;; (mail-hist-put-headers-into-history)) + (save-excursion + (run-hooks 'message-sent-hook)) + (message "Sending...done") + ;; Mark the buffer as unmodified and delete autosave. + (set-buffer-modified-p nil) + (delete-auto-save-file-if-necessary t) + (message-disassociate-draft) + ;; Delete other mail buffers and stuff. + (message-do-send-housekeeping) + (message-do-actions message-send-actions) + ;; Return success. + t) + (kill-buffer message-encoding-buffer))))) (defun message-send-via-mail (arg) "Send the current message via mail." @@ -2225,7 +2403,8 @@ the user from the mailer." (message-check 'invisible-text (when (text-property-any (point-min) (point-max) 'invisible t) (put-text-property (point-min) (point-max) 'invisible nil) - (unless (yes-or-no-p "Invisible text found and made visible; continue posting? ") + (unless (yes-or-no-p + "Invisible text found and made visible; continue posting? ") (error "Invisible text found and made visible"))))) (defun message-add-action (action &rest types) @@ -2249,11 +2428,56 @@ the user from the mailer." (eval (car actions))))) (pop actions))) +(defsubst message-maybe-split-and-send-mail () + "Split a message if necessary, and send it via mail. +Returns nil if sending succeeded, returns any string if sending failed. +This sub function is for exclusive use of `message-send-mail'." + (let ((mime-edit-split-ignored-field-regexp + mime-edit-split-ignored-field-regexp) + (case-fold-search t) + failure) + (while (string-match "Message-ID" mime-edit-split-ignored-field-regexp) + (setq mime-edit-split-ignored-field-regexp + (concat (substring mime-edit-split-ignored-field-regexp + 0 (match-beginning 0)) + "Hey_MIME-Edit,_there_is_an_inviolable_Message_ID" + "_so_don't_rape_it!" + (substring mime-edit-split-ignored-field-regexp + (match-end 0))))) + (setq failure + (or + (catch 'message-sending-mail-failure + (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 " " (message-make-message-id)))) + (condition-case err + (funcall message-send-mail-function) + (error + (throw 'message-sending-mail-failure err)))))) + nil) + (condition-case err + (progn + (funcall message-send-mail-function) + nil) + (error err)))) + (when failure + (if (eq 'error (car failure)) + (cadr failure) + (prin1-to-string failure))))) + (defun message-send-mail (&optional arg) (require 'mail-utils) (let ((tembuf (message-generate-new-buffer-clone-locals " message temp")) (case-fold-search nil) - (news (message-news-p))) + (news (message-news-p)) + failure) (save-restriction (message-narrow-to-headers) ;; Insert some headers. @@ -2262,46 +2486,36 @@ the user from the mailer." (message-generate-headers message-required-mail-headers)) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) - (unwind-protect - (save-excursion - (set-buffer tembuf) - (erase-buffer) - (insert-buffer message-encoding-buffer) - ;; Remove some headers. - (save-restriction - (message-narrow-to-headers) + (if (not (message-check-mail-syntax)) + (progn + (message "") + nil) + (unwind-protect + (save-excursion + (set-buffer tembuf) + (erase-buffer) + (insert-buffer message-encoding-buffer) ;; Remove some headers. - (message-remove-header message-ignored-mail-headers t)) - (goto-char (point-max)) - ;; require one newline at the end. - (or (= (preceding-char) ?\n) - (insert ?\n)) - (when (and news - (or (message-fetch-field "cc") - (message-fetch-field "to"))) - (message-insert-courtesy-copy)) -;; (mime-edit-maybe-split-and-send -;; (function -;; (lambda () -;; (interactive) -;; (funcall message-send-mail-function) -;; ))) - (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-mail-function)))) - (funcall message-send-mail-function)) - (kill-buffer tembuf)) - (set-buffer message-edit-buffer) - (push 'mail message-sent-message-via))) + (save-restriction + (message-narrow-to-headers) + ;; Remove some headers. + (message-remove-header message-ignored-mail-headers t)) + (goto-char (point-max)) + ;; require one newline at the end. + (or (= (preceding-char) ?\n) + (insert ?\n)) + (when (and news + (or (message-fetch-field "cc") + (message-fetch-field "to"))) + (message-insert-courtesy-copy)) + (setq failure (message-maybe-split-and-send-mail))) + (kill-buffer tembuf)) + (set-buffer message-edit-buffer) + (if failure + (progn + (message "Couldn't send message via mail: %s" failure) + nil) + (push 'mail message-sent-message-via))))) (defun message-send-mail-with-sendmail () "Send off the prepared buffer with sendmail." @@ -2330,31 +2544,31 @@ the user from the mailer." (save-excursion (set-buffer errbuf) (erase-buffer)))) - (let ((default-directory "/") - (coding-system-for-write message-send-coding-system)) - (apply 'call-process-region - (append (list (point-min) (point-max) - (if (boundp 'sendmail-program) - sendmail-program - "/usr/lib/sendmail") - nil errbuf nil "-oi") - ;; Always specify who from, - ;; since some systems have broken sendmails. - ;; But some systems are more broken with -f, so - ;; we'll let users override this. - (if (null message-sendmail-f-is-evil) - (list "-f" (user-login-name))) - ;; These mean "report errors by mail" - ;; and "deliver in background". - (if (null message-interactive) '("-oem" "-odb")) - ;; Get the addresses from the message - ;; unless this is a resend. - ;; We must not do that for a resend - ;; because we would find the original addresses. - ;; For a resend, include the specific addresses. - (if resend-to-addresses - (list resend-to-addresses) - '("-t"))))) + (let ((default-directory "/")) + (as-binary-process + (apply 'call-process-region + (append (list (point-min) (point-max) + (if (boundp 'sendmail-program) + sendmail-program + "/usr/lib/sendmail") + nil errbuf nil "-oi") + ;; Always specify who from, + ;; since some systems have broken sendmails. + ;; But some systems are more broken with -f, so + ;; we'll let users override this. + (if (null message-sendmail-f-is-evil) + (list "-f" (user-login-name))) + ;; These mean "report errors by mail" + ;; and "deliver in background". + (if (null message-interactive) '("-oem" "-odb")) + ;; Get the addresses from the message + ;; unless this is a resend. + ;; We must not do that for a resend + ;; because we would find the original addresses. + ;; For a resend, include the specific addresses. + (if resend-to-addresses + (list resend-to-addresses) + '("-t")))))) (when message-interactive (save-excursion (set-buffer errbuf) @@ -2380,28 +2594,28 @@ to find out how to use this." (run-hooks 'message-send-mail-hook) ;; send the message (case - (let ((coding-system-for-write message-send-coding-system)) - (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)) + (as-binary-process + (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) @@ -2456,6 +2670,38 @@ to find out how to use this." (error "Sending failed; " result))) (error "Sending failed; no recipients")))) +(defsubst message-maybe-split-and-send-news (method) + "Split a message if necessary, and send it via news. +Returns nil if sending succeeded, returns t if sending failed. +This sub function is for exclusive use of `message-send-news'." + (let ((mime-edit-split-ignored-field-regexp + mime-edit-split-ignored-field-regexp) + (case-fold-search t)) + (while (string-match "Message-ID" mime-edit-split-ignored-field-regexp) + (setq mime-edit-split-ignored-field-regexp + (concat (substring mime-edit-split-ignored-field-regexp + 0 (match-beginning 0)) + "Hey_MIME-Edit,_there_is_an_inviolable_Message_ID" + "_so_don't_rape_it!" + (substring mime-edit-split-ignored-field-regexp + (match-end 0))))) + (or + (catch 'message-sending-news-failure + (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 " " (message-make-message-id)))) + (unless (funcall message-send-news-function method) + (throw 'message-sending-news-failure t))))) + nil) + (not (funcall message-send-news-function method))))) + (defun message-send-news (&optional arg) (let ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) (case-fold-search nil) @@ -2492,27 +2738,15 @@ to find out how to use this." ;; require one newline at the end. (or (= (preceding-char) ?\n) (insert ?\n)) - (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))) + (setq result (message-maybe-split-and-send-news method))) (kill-buffer tembuf)) (set-buffer message-edit-buffer) (if result - (push 'news message-sent-message-via) - (message "Couldn't send message via news: %s" - (nnheader-get-report (car method))) - nil)))) + (progn + (message "Couldn't send message via news: %s" + (nnheader-get-report (car method))) + nil) + (push 'news message-sent-message-via))))) ;; 1997-09-29 by MORIOKA Tomohiko (defun message-send-news-with-gnus (method) @@ -2524,12 +2758,6 @@ to find out how to use this." (replace-match "\n") (backward-char 1) (run-hooks 'message-send-news-hook) - ;;(require (car method)) - ;;(funcall (intern (format "%s-open-server" (car method))) - ;;(cadr method) (cddr method)) - ;;(setq result - ;; (funcall (intern (format "%s-request-post" (car method))) - ;; (cadr method))) (gnus-open-server method) (gnus-request-post method) )) @@ -2776,6 +3004,9 @@ to find out how to use this." (y-or-n-p "The article contains control characters. Really post? ") t)) + ;; Check 8bit characters. + (message-check '8bit + (message-check-8bit)) ;; Check excessive size. (message-check 'size (if (> (buffer-size) 60000) @@ -2793,15 +3024,60 @@ to find out how to use this." ;; Check the length of the signature. (message-check 'signature (goto-char (point-max)) - (if (or (not (re-search-backward message-signature-separator nil t)) - (search-forward message-forward-end-separator nil t)) - t - (if (> (count-lines (point) (point-max)) 5) - (y-or-n-p - (format - "Your .sig is %d lines; it should be max 4. Really post? " - (1- (count-lines (point) (point-max))))) - t))))) + (if (> (count-lines (point) (point-max)) 5) + (y-or-n-p + (format + "Your .sig is %d lines; it should be max 4. Really post? " + (1- (count-lines (point) (point-max))))) + t)))) + +(defun message-check-mail-syntax () + "Check the syntax of the message." + (save-excursion + (save-restriction + (widen) + (and + ;; We narrow to the headers and check them first. + (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-check-mail-header-syntax))) + ;; Check the body. + (save-excursion + (set-buffer message-edit-buffer) + (message-check-mail-body-syntax)))))) + +(defun message-check-mail-header-syntax () + t) + +(defun message-check-mail-body-syntax () + (and + ;; Check 8bit characters. + (message-check '8bit + (message-check-8bit) + ))) + +(defun message-check-8bit () + "Check the article contains 8bit characters." + (save-excursion + (set-buffer message-encoding-buffer) + (message-narrow-to-headers) + (let* ((case-fold-search t) + (field-value (message-fetch-field "content-transfer-encoding"))) + (if (and field-value + (member (downcase field-value) message-8bit-encoding-list)) + t + (widen) + (set-buffer (get-buffer-create " message syntax")) + (erase-buffer) + (goto-char (point-min)) + (set-buffer-multibyte nil) + (insert-buffer message-encoding-buffer) + (goto-char (point-min)) + (if (re-search-forward "[^\x00-\x7f]" nil t) + (y-or-n-p + "The article contains 8bit characters. Really post? ") + t))))) (defun message-checksum () "Return a \"checksum\" for the current buffer." @@ -2813,7 +3089,7 @@ to find out how to use this." (while (not (eobp)) (when (not (looking-at "[ \t\n]")) (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1) - (following-char)))) + (char-after)))) (forward-char 1))) sum)) @@ -2831,7 +3107,6 @@ 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 'message-before-do-fcc-hook) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) (replace-match "" t t) @@ -2854,7 +3129,6 @@ to find out how to use this." (rmail-output file 1 nil t) (let ((mail-use-rfc822 t)) (rmail-output file 1 t t)))))) - (kill-buffer (current-buffer))))) (defun message-output (filename) @@ -2903,7 +3177,8 @@ If NOW, use that time instead." (zone (nth 8 (decode-time now))) (sign "+")) (when (< zone 0) - (setq sign "")) + (setq sign "-") + (setq zone (- zone))) (concat (format-time-string "%d" now) ;; The month name of the %b spec is locale-specific. Pfff. @@ -3029,10 +3304,10 @@ If NOW, use that time instead." (let ((pair (std11-extract-address-components from))) (concat "\n (" (or (car pair) (cadr pair)) - "'s message of " + "'s message of \"" (if (or (not date) (string= date "")) "(unknown date)" date) - ")")))))))) + "\")")))))))) (defun message-make-distribution () "Make a Distribution header." @@ -3250,9 +3525,9 @@ Headers already prepared in the buffer are not modified." (progn ;; The header was found. We insert a space after the ;; colon, if there is none. - (if (/= (following-char) ? ) (insert " ") (forward-char 1)) + (if (/= (char-after) ? ) (insert " ") (forward-char 1)) ;; Find out whether the header is empty... - (looking-at "[ \t]*$"))) + (looking-at "[ \t]*\n[^ \t]"))) ;; So we find out what value we should insert. (setq value (cond @@ -3359,7 +3634,7 @@ Headers already prepared in the buffer are not modified." (goto-char (point-min)) (while (not (eobp)) (skip-chars-forward "^,\"" (point-max)) - (if (or (= (following-char) ?,) + (if (or (eq (char-after) ?,) (eobp)) (when (not quoted) (if (and (> (current-column) 78) @@ -3430,7 +3705,7 @@ Headers already prepared in the buffer are not modified." (search-backward ":" ) (widen) (forward-char 1) - (if (= (following-char) ? ) + (if (eq (char-after) ? ) (forward-char 1) (insert " "))) (t @@ -3444,17 +3719,27 @@ Headers already prepared in the buffer are not modified." (defun message-buffer-name (type &optional to group) "Return a new (unique) buffer name based on TYPE and TO." (cond + ;; Generate a new buffer name The Message Way. + ((eq message-generate-new-buffers 'unique) + (generate-new-buffer-name + (concat "*" type + (if to + (concat " to " + (or (car (std11-extract-address-components to)) + to) "") + "") + (if (and group (not (string= group ""))) (concat " on " group) "") + "*"))) ;; Check whether `message-generate-new-buffers' is a function, ;; and if so, call it. ((message-functionp message-generate-new-buffers) (funcall message-generate-new-buffers type to group)) - ;; Generate a new buffer name The Message Way. - (message-generate-new-buffers + ((eq message-generate-new-buffers 'unsent) (generate-new-buffer-name - (concat "*" type + (concat "*unsent " type (if to (concat " to " - (or (car (std11-extract-address-components to)) + (or (car (mail-extract-address-components to)) to) "") "") (if (and group (not (string= group ""))) (concat " on " group) "") @@ -3514,7 +3799,7 @@ Headers already prepared in the buffer are not modified." ;; Rename the buffer. (if message-send-rename-function (funcall message-send-rename-function) - (when (string-match "\\`\\*" (buffer-name)) + (when (string-match "\\`\\*\\(unsent \\)?" (buffer-name)) (rename-buffer (concat "*sent " (substring (buffer-name) (match-end 0))) t))) ;; Push the current buffer onto the list. @@ -3532,7 +3817,7 @@ Headers already prepared in the buffer are not modified." (when actions (setq message-send-actions actions)) (setq message-reply-buffer - (or (cdr (assq 'reply-buffer message-parameter-alist)) + (or (message-get-parameter 'reply-buffer) replybuffer)) (goto-char (point-min)) ;; Insert all the headers. @@ -3594,7 +3879,8 @@ Headers already prepared in the buffer are not modified." (setq buffer-file-name (expand-file-name "*message*" message-auto-save-directory)) (setq buffer-auto-save-file-name (make-auto-save-file-name))) - (clear-visited-file-modtime))) + (clear-visited-file-modtime) + (setq buffer-file-coding-system message-draft-coding-system))) (defun message-disassociate-draft () "Disassociate the message buffer from the drafts directory." @@ -3602,6 +3888,23 @@ Headers already prepared in the buffer are not modified." (nndraft-request-expire-articles (list message-draft-article) "drafts" nil t))) +(defun message-insert-headers () + "Generate the headers for the article." + (interactive) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (when (message-news-p) + (message-generate-headers + (delq 'Lines + (delq 'Subject + (copy-sequence message-required-news-headers))))) + (when (message-mail-p) + (message-generate-headers + (delq 'Lines + (delq 'Subject + (copy-sequence message-required-mail-headers)))))))) + ;;; @@ -3639,7 +3942,7 @@ OTHER-HEADERS is an alist of header/value pairs." from subject date to cc references message-id follow-to (inhibit-point-motion-hooks t) - mct never-mct mft mrt gnus-warning) + mct never-mct mft mrt gnus-warning in-reply-to) (save-restriction (message-narrow-to-head) ;; Allow customizations to have their say. @@ -3670,6 +3973,12 @@ OTHER-HEADERS is an alist of header/value pairs." gnus-warning (message-fetch-field "gnus-warning")) (when (and gnus-warning (string-match "<[^>]+>" gnus-warning)) (setq message-id (match-string 0 gnus-warning))) + ;; Get the references from "In-Reply-To" field if there were + ;; no references and "In-Reply-To" field looks promising. + (unless references + (when (and (setq in-reply-to (message-fetch-field "in-reply-to")) + (string-match "<[^>]+>" in-reply-to)) + (setq references (match-string 0 in-reply-to)))) ;; Remove any (buggy) Re:'s that are present and make a ;; proper one. (setq subject (message-make-followup-subject subject)) @@ -3700,7 +4009,7 @@ You should normally obey the Mail-Copies-To: header. sends a copy of your response to the author."))) (setq mct (or mrt from))) ((and (eq message-use-mail-copies-to 'ask) - (not + (not (message-y-or-n-p (concat "Obey Mail-Copies-To: " mct " ? ") t "\ You should normally obey the Mail-Copies-To: header. @@ -3863,7 +4172,7 @@ You should normally obey the Mail-Copies-To: header. sends a copy of your response to the author."))) (setq mct (or mrt from))) ((and (eq message-use-mail-copies-to 'ask) - (not + (not (message-y-or-n-p (concat "Obey Mail-Copies-To: " mct " ? ") t "\ You should normally obey the Mail-Copies-To: header. @@ -3996,6 +4305,7 @@ that further discussion should take place only in " "") mail-header-separator "\n" message-cancel-message) + (run-hooks 'message-cancel-hook) (message "Canceling your article...") (if (let ((message-syntax-checks 'dont-check-for-anything-just-trust-me) @@ -4005,6 +4315,10 @@ that further discussion should take place only in " (message "Canceling your article...done")) (kill-buffer buf))))) +(defun message-supersede-setup-for-mime-edit () + (set (make-local-variable 'message-setup-hook) nil) + (mime-edit-again)) + ;;;###autoload (defun message-supersede () "Start composing a message to supersede the current message. @@ -4038,7 +4352,11 @@ header line with the old Message-ID." (goto-char (point-max)) (insert mail-header-separator) (widen) - (forward-line 1))) + (when message-supersede-setup-function + (funcall message-supersede-setup-function)) + (run-hooks 'message-supersede-setup-hook) + (goto-char (point-min)) + (search-forward (concat "\n" mail-header-separator "\n") nil t))) ;;;###autoload (defun message-recover () @@ -4089,7 +4407,7 @@ header line with the old Message-ID." (replace-match "")) (buffer-string))) - + ;;; Forwarding messages. (defun message-forward-subject-author-subject (subject) @@ -4116,12 +4434,14 @@ the message." (current-buffer) (message-narrow-to-head) (let ((funcs message-make-forward-subject-function) - (subject (if message-wash-forwarded-subjects - (message-wash-subject - (or (eword-decode-unstructured-field-body - (message-fetch-field "Subject")) "")) - (or (eword-decode-unstructured-field-body - (message-fetch-field "Subject")) "")))) + (subject (message-fetch-field "Subject"))) + (setq subject + (if subject + (if message-wash-forwarded-subjects + (message-wash-subject + (nnheader-decode-subject subject)) + (nnheader-decode-subject subject)) + "(none)")) ;; Make sure funcs is a list. (and funcs (not (listp funcs)) @@ -4142,7 +4462,9 @@ Optional NEWS will use news to forward instead of mail." (let ((cur (current-buffer)) (subject (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)) ;; Put point where we want it before inserting the forwarded ;; message. (if message-signature-before-forwarded-message @@ -4217,10 +4539,15 @@ Optional NEWS will use news to forward instead of mail." ;; Send it. (let ((message-encoding-buffer (current-buffer)) (message-edit-buffer (current-buffer))) - (message-send-mail)) + (let (message-required-mail-headers) + (message-send-mail))) (kill-buffer (current-buffer))) (message "Resending message to %s...done" address))) +(defun message-bounce-setup-for-mime-edit () + (set (make-local-variable 'message-setup-hook) nil) + (mime-edit-again)) + ;;;###autoload (defun message-bounce () "Re-mail the current message. @@ -4260,6 +4587,9 @@ you." (message-remove-header message-ignored-bounced-headers t) (goto-char (point-max)) (insert mail-header-separator)) + (when message-bounce-setup-function + (funcall message-bounce-setup-function)) + (run-hooks 'message-bounce-setup-hook) (message-position-point))) ;;; @@ -4337,7 +4667,7 @@ which specify the range to operate on." (goto-char (min start end)) (while (< (point) end1) (or (looking-at "[_\^@- ]") - (insert (following-char) "\b")) + (insert (char-after) "\b")) (forward-char 1))))) ;;;###autoload @@ -4351,7 +4681,7 @@ which specify the range to operate on." (move-marker end1 (max start end)) (goto-char (min start end)) (while (re-search-forward "\b" end1 t) - (if (eq (following-char) (char-after (- (point) 2))) + (if (eq (char-after) (char-after (- (point) 2))) (delete-char -2)))))) (defalias 'message-exchange-point-and-mark 'exchange-point-and-mark) @@ -4461,7 +4791,8 @@ regexp varstr." (let ((locals (save-excursion (set-buffer buffer) (buffer-local-variables))) - (regexp "^gnus\\|^nn\\|^message")) + (regexp + "^\\(gnus\\|nn\\|message\\|user-\\(mail-address\\|full-name\\)\\)")) (mapcar (lambda (local) (when (and (consp local) @@ -4478,9 +4809,14 @@ regexp varstr." (defun message-maybe-encode () (when message-mime-mode + ;; Inherit the buffer local variable `mime-edit-pgp-processing'. + (let ((pgp-processing (with-current-buffer message-edit-buffer + mime-edit-pgp-processing))) + (setq mime-edit-pgp-processing pgp-processing)) (run-hooks 'mime-edit-translate-hook) (if (catch 'mime-edit-error (save-excursion + (mime-edit-pgp-enclose-buffer) (mime-edit-translate-body) )) (error "Translation error!") @@ -4492,7 +4828,8 @@ regexp varstr." (defun message-mime-insert-article (&optional full-headers) (interactive "P") (let ((message-cite-function 'mime-edit-inserted-message-filter) - (message-reply-buffer (message-get-original-reply-buffer)) + (message-reply-buffer + (message-get-parameter-with-eval 'original-buffer)) (start (point))) (message-yank-original nil) (save-excursion @@ -4528,34 +4865,51 @@ regexp varstr." ;;; MIME functions ;;; +(defvar message-inhibit-body-encoding t) + (defun message-encode-message-body () - "Examine the message body, encode it, and add the requisite headers." - (when (featurep 'mule) - (let (old-headers) - (save-excursion - (save-restriction - (message-narrow-to-headers-or-head) - (unless (setq old-headers (message-fetch-field "mime-version")) - (message-remove-header - "^Content-Transfer-Encoding:\\|^Content-Type:\\|^Mime-Version:" t)) - (goto-char (point-max)) - (widen) - (narrow-to-region (point) (point-max)) - (let* ((charset (mm-encode-body)) - (encoding (mm-body-encoding))) - (when (consp charset) - (error "Can't encode messages with multiple charsets (yet)")) - (widen) - (message-narrow-to-headers-or-head) - (goto-char (point-max)) - (setq charset (or charset - (mm-mule-charset-to-mime-charset 'ascii))) - ;; We don't insert MIME headers if they only say the default. - (when (and (not old-headers) - (not (and (eq charset 'us-ascii) - (eq encoding '7bit)))) - (mm-insert-rfc822-headers charset encoding)) - (mm-encode-body))))))) + (unless message-inhibit-body-encoding + (let ((mail-parse-charset (or mail-parse-charset + message-default-charset + message-posting-charset)) + (case-fold-search t) + lines content-type-p) + (message-goto-body) + (save-restriction + (narrow-to-region (point) (point-max)) + (let ((new (mml-generate-mime))) + (when new + (delete-region (point-min) (point-max)) + (insert new) + (goto-char (point-min)) + (if (eq (aref new 0) ?\n) + (delete-char 1) + (search-forward "\n\n") + (setq lines (buffer-substring (point-min) (1- (point)))) + (delete-region (point-min) (point)))))) + (save-restriction + (message-narrow-to-headers-or-head) + (message-remove-header "Mime-Version") + (goto-char (point-max)) + (insert "MIME-Version: 1.0\n") + (when lines + (insert lines)) + (setq content-type-p + (re-search-backward "^Content-Type:" nil t))) + (save-restriction + (message-narrow-to-headers-or-head) + (message-remove-first-header "Content-Type") + (message-remove-first-header "Content-Transfer-Encoding")) + ;; We always make sure that the message has a Content-Type header. + ;; This is because some broken MTAs and MUAs get awfully confused + ;; when confronted with a message with a MIME-Version header and + ;; without a Content-Type header. For instance, Solaris' + ;; /usr/bin/mail. + (unless content-type-p + (goto-char (point-min)) + (re-search-forward "^MIME-Version:") + (forward-line 1) + (insert "Content-Type: text/plain; charset=us-ascii\n"))))) (defvar message-save-buffer " *encoding") (defun message-save-drafts () @@ -4572,8 +4926,8 @@ regexp varstr." (set-buffer buffer) (set-buffer-modified-p nil))) -(run-hooks 'message-load-hook) - (provide 'message) +(run-hooks 'message-load-hook) + ;;; message.el ends here