X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=lisp%2Fmessage.el;h=27ad5752db1739a3cbdfe1166a88d53ceb8685f2;hb=2143764e8da9fb2c9c431bcd467b54710a6700f7;hp=ed6430ec4250f4984a82272e483783d70f337383;hpb=699b0f6f3746e2405e7324922a3d6211b1e39ec2;p=elisp%2Fgnus.git- diff --git a/lisp/message.el b/lisp/message.el index ed6430e..27ad575 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -4,9 +4,10 @@ ;; 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. @@ -34,11 +35,8 @@ ;;; Code: -(eval-when-compile - (require 'cl) - (require 'smtp) - ) - +(eval-when-compile (require 'cl)) +(eval-when-compile (require 'smtp)) (require 'mailheader) (require 'nnheader) (require 'easymenu) @@ -47,6 +45,7 @@ (require 'mail-abbrevs) (require 'mailabbrev)) (require 'mime-edit) +(eval-when-compile (require 'static)) ;; Avoid byte-compile warnings. (eval-when-compile @@ -201,7 +200,8 @@ Don't touch this variable unless you really know what you're doing. Checks include subject-cmsg multiple-headers sendsys message-id from long-lines control-chars size new-text redirected-followup signature approved sender empty empty-headers message-id from subject -shorten-followup-to existing-newsgroups buffer-file-name unchanged." +shorten-followup-to existing-newsgroups buffer-file-name unchanged +newsgroups." :group 'message-news) (defcustom message-required-news-headers @@ -310,7 +310,7 @@ is the symbol `guess', try to detect \"Re: \" within an encoded-word." :type 'regexp :group 'message-various) -(defcustom message-elide-elipsis "\n[...]\n\n" +(defcustom message-elide-ellipsis "\n[...]\n\n" "*The string which is inserted for elided text." :type 'string :group 'message-various) @@ -389,7 +389,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 @@ -405,6 +405,11 @@ The provided functions are: :type '(radio (function-item message-forward-subject-author-subject) (function-item message-forward-subject-fwd))) +(defcustom message-forward-as-mime t + "*If non-nil, forward messages as an inline/rfc822 MIME section. Otherwise, directly inline the old message in the forwarded message." + :group 'message-forwarding + :type 'boolean) + (defcustom message-wash-forwarded-subjects nil "*If non-nil, try to remove as much old cruft as possible from the subject of messages before generating the new subject of a forward." :group 'message-forwarding @@ -415,6 +420,12 @@ The provided functions are: :group 'message-interface :type 'regexp) +(defcustom message-forward-ignored-headers nil + "*All headers that match this regexp will be deleted when forwarding a message." + :group 'message-forwarding + :type '(choice (const :tag "None" nil) + regexp)) + (defcustom message-ignored-cited-headers "." "*Delete these headers from the messages you yank." :group 'message-insertion @@ -432,7 +443,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) @@ -521,10 +532,9 @@ is never used." (const :tag "always" use) (const :tag "ask" ask))) -;; stuff relating to broken sendmail in MMDF (defcustom message-sendmail-f-is-evil nil - "*Non-nil means that \"-f username\" should not be added to the sendmail -command line, because it is even more evil than leaving it out." + "*Non-nil means that \"-f username\" should not be added to the sendmail command line. +Doing so would be even more evil than leaving it out." :group 'message-sending :type 'boolean) @@ -544,6 +554,11 @@ might set this variable to '(\"-f\" \"you@some.where\")." :group 'message-sending :type '(repeat string)) +(defvar message-cater-to-broken-inn t + "Non-nil means Gnus should not fold the `References' header. +Folding `References' makes ancient versions of INN create incorrect +NOV lines.") + (defvar gnus-post-method) (defvar gnus-select-method) (defcustom message-post-method @@ -603,7 +618,7 @@ The function `message-supersede' runs this hook." :group 'message-various :type 'hook) -(defcustom message-header-hook '(eword-encode-header) +(defcustom message-header-hook '((lambda () (eword-encode-header t))) "Hook run in a message mode buffer narrowed to the headers." :group 'message-various :type 'hook) @@ -625,6 +640,24 @@ The function `message-supersede' runs this hook." :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. +If it is a symbol `message-id-only', only an ID from \"Message-ID\" field +is used, otherwise IDs extracted from \"References\", \"In-Reply-To\" and +\"Message-ID\" fields are used." + :type '(radio (const :tag "Do not add anything" nil) + (const :tag "From Message-Id, References and In-Reply-To fields" t) + (const :tag "From only Message-Id field." message-id-only)) + :group 'message-insertion) + +(defcustom message-list-references-add-position nil + "Integer value means position for adding to \"References\" field when +an article is yanked by the command `message-yank-original' interactively." + :type '(radio (const :tag "Add to last" nil) + (integer :tag "Position from last ID")) + :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'." @@ -638,6 +671,8 @@ 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 mu-cite-original) (function-item sc-cite-original) (function :tag "Other")) :group 'message-insertion) @@ -767,11 +802,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.") @@ -809,6 +843,18 @@ Valid valued are `unique' and `unsent'." :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) + +(defcustom message-dont-reply-to-names rmail-dont-reply-to-names + "*A regexp specifying names to prune when doing wide replies. +A value of nil means exclude your own name only." + :group 'message + :type '(choice (const :tag "Yourself" nil) + regexp)) + ;;; Internal variables. ;;; Well, not really internal. @@ -948,10 +994,152 @@ Defaults to `text-mode-abbrev-table'.") "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_.@-")) - (content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)")) +(defvar message-font-lock-fence-open-regexp "[+|]" + "*Regexp that matches fence open string.") + +(defvar message-font-lock-fence-close-regexp "|" + "*Regexp that matches fence close string.") + +(defvar message-font-lock-fence-open-position nil + "*Cons of SYMBOL of a function or a variable and a number of OFFSET that +indicate the fence open position. If it is non-nil, +`message-font-lock-fence-open-regexp' is not used for searching for the +fence open position. If SYMBOL is a function, it is called with one argument +last cursor position and should return the fence open position as a number +or a marker. If SYMBOL is a variable symbol, the value is examined with +`symbol-value'. OFFSET is added to the position to compensate the value. +For example, the following combinations of variable symbol and offset value +can be used: + +Egg v3: '(egg:*region-start* . -1) +Canna: '(canna:*region-start* . 0) +") + +(defvar message-font-lock-fence-close-position nil + "*Cons of SYMBOL of a function or a variable and a number of OFFSET that +indicate the fence close position. If it is non-nil, +`message-font-lock-fence-close-regexp' is not used for searching for the +fence close position. If SYMBOL is a function, it is called with one argument +last cursor position and should return the fence close position as a number +or a marker. If SYMBOL is a variable symbol, the value is examined with +`symbol-value'. OFFSET is added to the position to compensate the value. +For example, the following combinations of variable symbol and offset value +can be used: + +Egg v3: '(egg:*region-end* . 0) +Canna: '(canna:*region-end* . 0) +") + +(defvar message-font-lock-cited-text-regexp + "^[\t ]*\\([^\000- :>|}\177]*\\)[:>|}].*" + "*Regexp that matches cited text. It should have a grouping for the +citation prefix which is ended at the beginning of citation mark string.") + +(defvar message-font-lock-citation-name-max-column 10 + "*Maximun number of column for citation name for fontifying.") + +(defvar message-font-lock-last-position nil + "Internal buffer local variable to save the last cursor position +before fontifying.") + +(eval-after-load "font-lock" + '(defadvice font-lock-after-change-function + (before message-font-lock-save-last-position activate) + "Save last cursor position before fontifying." + (if (eq 'message-mode major-mode) + (setq message-font-lock-last-position (point))))) + +(defun message-font-lock-cited-text-matcher (limit) + "Search for a cited text containing `message-font-lock-cited-text-regexp' +forward. Argument LIMIT bounds the search. If a cited text is found, it +returns t and sets match data 1 and 2, otherwise it returns nil. Normally, +match data 2 has zero length, but if the FENCE (for input method) is detected +in matched text, result is divided into match data 1 and 2 across the FENCE. +See also the documentations for the following variables: + `message-font-lock-fence-open-regexp' + `message-font-lock-fence-close-regexp' + `message-font-lock-fence-open-position' + `message-font-lock-fence-close-position' +" + (prog1 + (when (re-search-forward message-font-lock-cited-text-regexp limit t) + (let* ((start0 (match-beginning 0)) + (end0 (match-end 0)) + (cite-mark (match-end 1)) + (should-fontify + (progn + (goto-char cite-mark) + (<= (current-column) + message-font-lock-citation-name-max-column))) + end1 start2) + (and + should-fontify + message-font-lock-last-position + (>= message-font-lock-last-position start0) + (<= message-font-lock-last-position end0) + (cond + (message-font-lock-fence-open-position + (let* ((symbol (car message-font-lock-fence-open-position)) + (open + (cond ((functionp symbol) + (funcall symbol message-font-lock-last-position)) + ((and (symbolp symbol) + (boundp symbol)) + (symbol-value symbol))))) + (when (markerp open) + (setq open (marker-position open))) + (and (numberp open) + (setq open + (+ open + (cdr message-font-lock-fence-open-position))) + (>= message-font-lock-last-position open) + (goto-char open) + (or (not message-font-lock-fence-open-regexp) + (looking-at message-font-lock-fence-open-regexp)) + (setq end1 open)))) + (message-font-lock-fence-open-regexp + (goto-char message-font-lock-last-position) + (when (re-search-backward + message-font-lock-fence-open-regexp start0 t) + (setq end1 (match-beginning 0))))) + (setq should-fontify + (and message-font-lock-fence-open-position + (not (eq cite-mark end1)))) + (cond + (message-font-lock-fence-close-position + (let* ((symbol (car message-font-lock-fence-close-position)) + (close + (cond ((functionp symbol) + (funcall symbol message-font-lock-last-position)) + ((and (symbolp symbol) + (boundp symbol)) + (symbol-value symbol))))) + (when (markerp close) + (setq close (marker-position close))) + (and (numberp close) + (setq close + (+ close + (cdr message-font-lock-fence-close-position))) + (<= message-font-lock-last-position close) + (setq start2 close)))) + (message-font-lock-fence-close-regexp + (goto-char message-font-lock-last-position) + (when (looking-at message-font-lock-fence-close-regexp) + (setq start2 (match-end 0))))) + (setq should-fontify + (and (not (and (not message-font-lock-fence-open-position) + (eq cite-mark end1))) + (not (eq cite-mark start2))))) + (goto-char end0) + (when should-fontify + (if start2 + (store-match-data (list start0 end0 start0 end1 start2 end0)) + (store-match-data (list start0 end0 start0 end0 end0 end0))) + t))) + (setq message-font-lock-last-position nil))) + +(defvar message-font-lock-keywords-1 + (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)")) `((,(concat "^\\([Tt]o:\\)" content) (1 'message-header-name-face) (2 'message-header-to-face nil t)) @@ -977,18 +1165,27 @@ Defaults to `text-mode-abbrev-table'.") (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)) - ("<#/?\\(multipart\\|part\\|external\\).*>" - (0 'message-mml-face)))) + nil)))) + +(defvar message-font-lock-keywords-2 + (append message-font-lock-keywords-1 + '((message-font-lock-cited-text-matcher + (1 'message-cited-text-face) + (2 'message-cited-text-face)) + ("<#/?\\(multipart\\|part\\|external\\).*>" + (0 'message-mml-face))))) + +(defvar message-font-lock-keywords message-font-lock-keywords-2 "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)) +(put 'message-mode 'font-lock-defaults + '((message-font-lock-keywords + message-font-lock-keywords-1 + message-font-lock-keywords-2) + nil nil nil nil + (font-lock-mark-block-function . mark-paragraph))) (defvar message-face-alist '((bold . bold-region) @@ -1032,19 +1229,18 @@ 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-draft-coding-system - (cond +(defvar message-draft-coding-system + (cond + ((boundp 'MULE) '*junet*) ((not (fboundp 'find-coding-system)) nil) - ((find-coding-system 'emacs-mule) 'emacs-mule) + ((find-coding-system 'emacs-mule) + (if (memq system-type '(windows-nt ms-dos ms-windows)) + 'emacs-mule-dos 'emacs-mule)) ((find-coding-system 'escape-quoted) 'escape-quoted) ((find-coding-system 'no-conversion) 'no-conversion) (t nil)) "Coding system to compose mail.") -(defvar message-default-charset 'iso-8859-1 - "Default charset assumed to be used when viewing non-ASCII characters. -This variable is used only in non-Mule Emacsen.") - ;;; Internal variables. (defvar message-buffer-list nil) @@ -1052,6 +1248,7 @@ This variable is used only in non-Mule Emacsen.") (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) @@ -1119,6 +1316,7 @@ This variable is used only in non-Mule Emacsen.") "^ *---+ +Original message +---+ *$\\|" "^ *--+ +begin message +--+ *$\\|" "^ *---+ +Original message follows +---+ *$\\|" + "^ *---+ +Undelivered message follows +---+ *$\\|" "^|? *---+ +Message text follows: +---+ *|?$") "A regexp that matches the separator before the text of a failed message.") @@ -1136,7 +1334,7 @@ This variable is used only in non-Mule Emacsen.") (Lines) (Expires) (Message-ID) - (References . message-fill-header) + (References . message-shorten-references) (User-Agent)) "Alist used for formatting headers.") @@ -1154,7 +1352,8 @@ This variable is used only in non-Mule Emacsen.") (autoload 'gnus-request-post "gnus-int") (autoload 'gnus-copy-article-buffer "gnus-msg") (autoload 'gnus-alive-p "gnus-util") - (autoload 'rmail-output "rmail")) + (autoload 'rmail-output "rmail") + (autoload 'mu-cite-original "mu-cite")) @@ -1238,7 +1437,7 @@ This variable is used only in non-Mule Emacsen.") (when value (while (string-match "\n[\t ]+" value) (setq value (replace-match " " t t value))) - ;; We remove all text props.delete-region + ;; We remove all text props. (format "%s" value)))) (defun message-narrow-to-field () @@ -1268,6 +1467,7 @@ This variable is used only in non-Mule Emacsen.") (insert (car headers) ?\n)))) (setq headers (cdr headers)))) + (defun message-fetch-reply-field (header) "Fetch FIELD from the message we're replying to." (let ((buffer (message-eval-parameter message-reply-buffer))) @@ -1412,6 +1612,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 () @@ -1478,6 +1679,7 @@ Point is left at the beginning of the narrowed-to region." (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups) (define-key message-mode-map "\C-c\C-y" 'message-yank-original) + (define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer) (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) @@ -1515,6 +1717,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] @@ -1549,6 +1752,7 @@ Point is left at the beginning of the narrowed-to region." "Major mode for editing mail and news to be sent. Like Text Mode but with these additional commands: C-c C-s message-send (send the message) C-c C-c message-send-and-exit +C-c C-d Pospone sending the message C-c C-k Kill the message C-c C-f move to a header field (and create it if there isn't): C-c C-f C-t move to To C-c C-f C-s move to Subject C-c C-f C-c move to Cc C-c C-f C-b move to Bcc @@ -1567,12 +1771,13 @@ 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-v message-delete-not-region (remove the text outside the region). 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)." +C-c C-r message-caesar-buffer-body (rot13 the message body). +M-RET message-newline-and-reformat (break the line and reformat)." (interactive) (kill-all-local-variables) (set (make-local-variable 'message-reply-buffer) nil) - (make-local-variable 'message-send-actions) - (make-local-variable 'message-exit-actions) + (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) @@ -1630,16 +1835,24 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (message-set-auto-save-file-name) (unless (string-match "XEmacs" emacs-version) (set (make-local-variable 'font-lock-defaults) - '(message-font-lock-keywords t))) + '((message-font-lock-keywords + message-font-lock-keywords-1 + message-font-lock-keywords-2) + nil nil nil nil + (font-lock-mark-block-function . mark-paragraph)))) + (set (make-local-variable 'message-font-lock-last-position) nil) (make-local-variable 'adaptive-fill-regexp) (setq adaptive-fill-regexp - (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|" adaptive-fill-regexp)) + (concat "[ \t]*[-a-z0-9A-Z]*\\(>[ \t]*\\)+[ \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]*\\|" + (concat "[ \t]*[-a-z0-9A-Z]*\\(>[ \t]*\\)+[ \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)) @@ -1725,13 +1938,14 @@ 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." (interactive) (message-goto-body) - (forward-line -2)) + (forward-line -1)) (defun message-goto-signature () "Move point to the beginning of the message signature. @@ -1809,17 +2023,24 @@ With the prefix argument FORCE, insert the header anyway." (defun message-newline-and-reformat () "Insert four newlines, and then reformat if inside quoted text." (interactive) - (let ((point (point)) - quoted) - (save-excursion - (beginning-of-line) - (setq quoted (looking-at (regexp-quote message-yank-prefix)))) - (insert "\n\n\n\n") + (let ((prefix "[]>ยป|:}+ \t]*") + (supercite-thing "[-._a-zA-Z0-9]*[>]+[ \t]*") + quoted point) + (unless (bolp) + (save-excursion + (beginning-of-line) + (when (looking-at (concat prefix + supercite-thing)) + (setq quoted (match-string 0)))) + (insert "\n")) + (setq point (point)) + (insert "\n\n\n") + (delete-region (point) (re-search-forward "[ \t]*")) (when quoted - (insert message-yank-prefix)) + (insert quoted)) (fill-paragraph nil) (goto-char point) - (forward-line 2))) + (forward-line 1))) (defun message-insert-signature (&optional force) "Insert a signature. See documentation for the `message-signature' variable." @@ -1860,13 +2081,11 @@ With the prefix argument FORCE, insert the header anyway." (defun message-elide-region (b e) "Elide the text between point and mark. -An ellipsis (from `message-elide-elipsis') will be inserted where the +An ellipsis (from `message-elide-ellipsis') will be inserted where the text was killed." (interactive "r") (kill-region b e) - (unless (bolp) - (insert "\n")) - (insert message-elide-elipsis)) + (insert message-elide-ellipsis)) (defvar message-caesar-translation-table nil) @@ -1935,7 +2154,7 @@ Mail and USENET news headers are not rotated." (unless (equal 0 (call-process-region (point-min) (point-max) program t t)) (insert body) - (message "%s failed." program)))))) + (message "%s failed" program)))))) (defun message-rename-buffer (&optional enter-string) "Rename the *message* buffer to \"*message* RECIPIENT\". @@ -1969,7 +2188,7 @@ Numeric argument means justify as well." (goto-char (point-min)) (search-forward (concat "\n" mail-header-separator "\n") nil t) (let ((fill-prefix message-yank-prefix)) - (fill-individual-paragraphs (point) (point-max) justifyp t)))) + (fill-individual-paragraphs (point) (point-max) justifyp)))) (defun message-indent-citation () "Modify text just inserted from a message to be cited. @@ -2017,6 +2236,39 @@ 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 saved-id) + (when (and refs-list + (integerp message-list-references-add-position)) + (let ((pos message-list-references-add-position)) + (while (and refs-list + (> pos 0)) + (setq saved-id (cons (car refs-list) saved-id) + refs-list (cdr refs-list) + pos (1- pos))))) + (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)))))) + (while saved-id + (setq refs-list (cons (car saved-id) refs-list) + saved-id (cdr saved-id))) + refs-list)) + (defvar gnus-article-copy) (defun message-yank-original (&optional arg) "Insert the message being replied to, if any. @@ -2027,14 +2279,55 @@ 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. +\(See also `message-yank-add-new-references'.)" (interactive "P") (let ((modified (buffer-modified-p)) - (buffer (message-eval-parameter message-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 + (unless (eq message-yank-add-new-references + 'message-id-only) + (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) @@ -2042,6 +2335,24 @@ prefix, and don't delete any headers." (unless modified (setq message-checksum (message-checksum)))))) +(defun message-yank-buffer (buffer) + "Insert BUFFER into the current buffer and quote it." + (interactive "bYank buffer: ") + (let ((message-reply-buffer buffer)) + (save-window-excursion + (message-yank-original)))) + +(defun message-buffers () + "Return a list of active message buffers." + (let (buffers) + (save-excursion + (dolist (buffer (buffer-list t)) + (set-buffer buffer) + (when (and (eq major-mode 'message-mode) + (null message-sent-message-via)) + (push (buffer-name buffer) buffers)))) + (nreverse buffers))) + (defun message-cite-original-without-signature () "Cite function in the standard Message manner." (let ((start (point)) @@ -2067,7 +2378,7 @@ 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) @@ -2215,9 +2526,9 @@ The text will also be indented the normal way." (defun message-delete-frame (frame org-frame) "Delete frame for editing message." - (when (and (or (and (featurep 'xemacs) - (not (eq 'tty (device-type)))) - window-system + (when (and (or (static-if (featurep 'xemacs) + (device-on-window-system-p) + window-system) (>= emacs-major-version 20)) (or (and (eq message-delete-frame-on-exit t) (select-frame frame) @@ -2274,31 +2585,33 @@ the user from the mailer." (message-fix-before-sending) (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))))) + (when (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) - ;; (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)))) + (unless (or sent (not success)) + (error "No methods specified to send by")) + (prog1 + (when (and success sent) + (message-do-fcc) + (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." @@ -2327,7 +2640,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) @@ -2421,6 +2735,10 @@ This sub function is for exclusive use of `message-send-mail'." ;; Remove some headers. (save-restriction (message-narrow-to-headers) +;; We Semi-gnus people have no use for it. +;; ;; We (re)generate the Lines header. +;; (when (memq 'Lines message-required-mail-headers) +;; (message-generate-headers '(Lines))) ;; Remove some headers. (message-remove-header message-ignored-mail-headers t)) (goto-char (point-max)) @@ -2443,7 +2761,7 @@ This sub function is for exclusive use of `message-send-mail'." (defun message-send-mail-with-sendmail () "Send off the prepared buffer with sendmail." (let ((errbuf (if message-interactive - (generate-new-buffer " sendmail errors") + (message-generate-new-buffer-clone-locals " sendmail errors") 0)) resend-to-addresses delimline) (let ((case-fold-search t)) @@ -2480,7 +2798,10 @@ This sub function is for exclusive use of `message-send-mail'." ;; 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))) + (list "-f" + (if (null user-mail-address) + (user-login-name) + user-mail-address))) ;; These mean "report errors by mail" ;; and "deliver in background". (if (null message-interactive) '("-oem" "-odb")) @@ -2655,6 +2976,10 @@ This sub function is for exclusive use of `message-send-news'." ;; Remove some headers. (save-restriction (message-narrow-to-headers) +;; We Semi-gnus people have no use for it. +;; ;; We (re)generate the Lines header. +;; (when (memq 'Lines message-required-mail-headers) +;; (message-generate-headers '(Lines))) ;; Remove some headers. (message-remove-header message-ignored-news-headers t)) (goto-char (point-max)) @@ -2681,12 +3006,6 @@ This sub function is for exclusive use of `message-send-news'." (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) )) @@ -2721,6 +3040,15 @@ This sub function is for exclusive use of `message-send-news'." (defun message-check-news-header-syntax () (and + ;; Check Newsgroups header. + (message-check 'newsgroyps + (let ((group (message-fetch-field "newsgroups"))) + (or + (and group + (not (string-match "\\`[ \t]*\\'" group))) + (ignore + (message + "The newsgroups field is empty or missing. Posting is denied."))))) ;; Check the Subject header. (message-check 'subject (let* ((case-fold-search t) @@ -2883,12 +3211,15 @@ This sub function is for exclusive use of `message-send-news'." (message-check 'from (let* ((case-fold-search t) (from (message-fetch-field "from")) - (ad (nth 1 (std11-extract-address-components from)))) + ad) (cond ((not from) (message "There is no From line. Posting is denied.") nil) - ((or (not (string-match "@[^\\.]*\\." ad)) ;larsi@ifi + ((or (not (string-match + "@[^\\.]*\\." + (setq ad (nth 1 (mail-extract-address-components + from))))) ;larsi@ifi (string-match "\\.\\." ad) ;larsi@ifi..uio (string-match "@\\." ad) ;larsi@.ifi.uio (string-match "\\.$" ad) ;larsi@ifi.uio. @@ -2953,15 +3284,12 @@ This sub function is for exclusive use of `message-send-news'." ;; 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." @@ -3029,6 +3357,7 @@ This sub function is for exclusive use of `message-send-news'." "Process Fcc headers in the current buffer." (let ((case-fold-search t) (coding-system-for-write 'raw-text) + (output-coding-system 'raw-text) list file) (save-excursion (set-buffer (get-buffer-create " *message temp*")) @@ -3119,7 +3448,7 @@ If NOW, use that time instead." parse-time-months)))) (format-time-string "%Y %H:%M:%S " now) ;; We do all of this because XEmacs doesn't have the %z spec. - (format "%s%02d%02d" sign (/ zone 3600) (% zone 3600))))) + (format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60))))) (defun message-make-followup-subject (subject) "Make a followup Subject." @@ -3459,7 +3788,7 @@ Headers already prepared in the buffer are not modified." ;; colon, if there is none. (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 @@ -3495,12 +3824,16 @@ Headers already prepared in the buffer are not modified." ;; This header didn't exist, so we insert it. (goto-char (point-max)) (insert (if (stringp header) header (symbol-name header)) - ": " value "\n") + ": " value) + (unless (bolp) + (insert "\n")) (forward-line -1)) ;; The value of this header was empty, so we clear ;; totally and insert the new value. (delete-region (point) (gnus-point-at-eol)) - (insert value)) + (insert value) + (when (bolp) + (delete-char -1))) ;; Add the deletable property to the headers that require it. (and (memq header message-deletable-headers) (progn (beginning-of-line) (looking-at "[^:]+: ")) @@ -3611,23 +3944,60 @@ Headers already prepared in the buffer are not modified." (replace-match " " t t)) (goto-char (point-max))))) +(defun message-shorten-1 (list cut surplus) + ;; Cut SURPLUS elements out of LIST, beginning with CUTth one. + (setcdr (nthcdr (- cut 2) list) + (nthcdr (+ (- cut 2) surplus 1) list))) + (defun message-shorten-references (header references) - "Limit REFERENCES to be shorter than 988 characters." - (let ((max 988) - (cut 4) + "Trim REFERENCES to be less than 31 Message-ID long, and fold them. +If folding is disallowed, also check that the REFERENCES are less +than 988 characters long, and if they are not, trim them until they are." + (let ((maxcount 31) + (count 0) + (cut 6) refs) (with-temp-buffer (insert references) (goto-char (point-min)) + ;; Cons a list of valid references. (while (re-search-forward "<[^>]+>" nil t) (push (match-string 0) refs)) - (setq refs (nreverse refs)) - (while (> (length (mapconcat 'identity refs " ")) max) - (when (< (length refs) (1+ cut)) - (decf cut)) - (setcdr (nthcdr cut refs) (cddr (nthcdr cut refs))))) - (insert (capitalize (symbol-name header)) ": " - (mapconcat 'identity refs " ") "\n"))) + (setq refs (nreverse refs) + count (length refs))) + + ;; If the list has more than MAXCOUNT elements, trim it by + ;; removing the CUTth element and the required number of + ;; elements that follow. + (when (> count maxcount) + (let ((surplus (- count maxcount))) + (message-shorten-1 refs cut surplus) + (decf count surplus))) + + ;; If folding is disallowed, make sure the total length (including + ;; the spaces between) will be less than MAXSIZE characters. + (when message-cater-to-broken-inn + (let ((maxsize 988) + (totalsize (+ (apply #'+ (mapcar #'length refs)) + (1- count))) + (surplus 0) + (ptr (nthcdr (1- cut) refs))) + ;; Decide how many elements to cut off... + (while (> totalsize maxsize) + (decf totalsize (1+ (length (car ptr)))) + (incf surplus) + (setq ptr (cdr ptr))) + ;; ...and do it. + (when (> surplus 0) + (message-shorten-1 refs cut surplus)))) + + ;; Finally, collect the references back into a string and insert + ;; it into the buffer. + (let ((refstring (mapconcat #'identity refs " "))) + (if message-cater-to-broken-inn + (insert (capitalize (symbol-name header)) ": " + refstring "\n") + (message-fill-header header refstring))))) (defun message-position-point () "Move point to where the user probably wants to find it." @@ -3680,40 +4050,36 @@ Headers already prepared in the buffer are not modified." (t (format "*%s message*" type)))) +(defmacro message-pop-to-buffer-1 (buffer) + `(if pop-up-frames + (let (special-display-buffer-names + special-display-regexps + same-window-buffer-names + same-window-regexps) + (pop-to-buffer ,buffer)) + (pop-to-buffer ,buffer))) + (defun message-pop-to-buffer (name) "Pop to buffer NAME, and warn if it already exists and is modified." - (let ((pop-up-frames pop-up-frames) - (special-display-buffer-names special-display-buffer-names) - (special-display-regexps special-display-regexps) - (same-window-buffer-names same-window-buffer-names) - (same-window-regexps same-window-regexps) - (buffer (get-buffer name)) - (cur (current-buffer))) - (if (or (and (featurep 'xemacs) - (not (eq 'tty (device-type)))) - window-system - (>= emacs-major-version 20)) - (when message-use-multi-frames - (setq pop-up-frames t - special-display-buffer-names nil - special-display-regexps nil - same-window-buffer-names nil - same-window-regexps nil)) - (setq pop-up-frames nil)) + (let ((buffer (get-buffer name)) + (pop-up-frames (and (or (static-if (featurep 'xemacs) + (device-on-window-system-p) + window-system) + (>= emacs-major-version 20)) + message-use-multi-frames))) (if (and buffer (buffer-name buffer)) (progn - (set-buffer (pop-to-buffer buffer)) + (message-pop-to-buffer-1 buffer) (when (and (buffer-modified-p) (not (y-or-n-p "Message already being composed; erase? "))) (error "Message being composed"))) - (set-buffer (pop-to-buffer name))) + (message-pop-to-buffer-1 name)) (erase-buffer) (message-mode) (when pop-up-frames - (make-local-variable 'message-original-frame) - (setq message-original-frame (selected-frame))))) + (set (make-local-variable 'message-original-frame) (selected-frame))))) (defun message-do-send-housekeeping () "Kill old message buffers." @@ -3812,7 +4178,9 @@ Headers already prepared in the buffer are not modified." message-auto-save-directory)) (setq buffer-auto-save-file-name (make-auto-save-file-name))) (clear-visited-file-modtime) - (setq buffer-file-coding-system message-draft-coding-system))) + (static-if (boundp 'MULE) + (set-file-coding-system message-draft-coding-system) + (setq buffer-file-coding-system message-draft-coding-system)))) (defun message-disassociate-draft () "Disassociate the message buffer from the drafts directory." @@ -3874,7 +4242,8 @@ 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) + (message-this-is-mail t) + mct never-mct mft mrt gnus-warning in-reply-to) (save-restriction (message-narrow-to-head) ;; Allow customizations to have their say. @@ -3905,6 +4274,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)) @@ -3935,7 +4310,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. @@ -3965,9 +4340,9 @@ directs your response to " (if (string-match "," mft) A typical situation where Mail-Followup-To is used is when the author thinks that further discussion should take place only in " - (if (string-match "," mft) - "the specified mailing lists" - "that mailing list") "."))) + (if (string-match "," mft) + "the specified mailing lists" + "that mailing list") "."))) (setq follow-to (list (cons 'To mft))) (when mct (push (cons 'Cc mct) follow-to))) @@ -3984,8 +4359,9 @@ that further discussion should take place only in " (while (re-search-forward "[ \t]+" nil t) (replace-match " " t t)) ;; Remove addresses that match `rmail-dont-reply-to-names'. - (insert (prog1 (rmail-dont-reply-to (buffer-string)) - (erase-buffer))) + (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) @@ -4098,7 +4474,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. @@ -4333,7 +4709,7 @@ header line with the old Message-ID." (replace-match "")) (buffer-string))) - + ;;; Forwarding messages. (defun message-forward-subject-author-subject (subject) @@ -4360,14 +4736,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 (nnheader-decode-subject - (message-fetch-field "Subject")) - "")) - (or (nnheader-decode-subject - (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)) @@ -4388,7 +4764,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 @@ -4419,7 +4797,8 @@ Optional NEWS will use news to forward instead of mail." ;;;###autoload (defun message-resend (address) "Resend the current article to ADDRESS." - (interactive "sResend message to: ") + (interactive + (list (message-read-from-minibuffer "Resend message to: "))) (message "Resending message to %s..." address) (save-excursion (let ((cur (current-buffer)) @@ -4707,10 +5086,10 @@ regexp varstr." (let ((oldbuf (current-buffer))) (save-excursion (set-buffer (generate-new-buffer name)) - (message-clone-locals oldbuf) + (message-clone-locals oldbuf varstr) (current-buffer)))) -(defun message-clone-locals (buffer) +(defun message-clone-locals (buffer &optional varstr) "Clone the local variables from BUFFER to the current buffer." (let ((locals (save-excursion (set-buffer buffer) @@ -4721,7 +5100,9 @@ regexp varstr." (lambda (local) (when (and (consp local) (car local) - (string-match regexp (symbol-name (car local)))) + (string-match regexp (symbol-name (car local))) + (or (null varstr) + (string-match varstr (symbol-name (car local))))) (ignore-errors (set (make-local-variable (car local)) (cdr local))))) @@ -4733,9 +5114,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!") @@ -4784,122 +5170,60 @@ regexp varstr." ;;; MIME functions ;;; -(defun message-mime-query-file (prompt) - (let ((file (read-file-name prompt nil nil t))) - ;; Prevent some common errors. This is inspired by similar code in - ;; VM. - (when (file-directory-p file) - (error "%s is a directory, cannot attach" file)) - (unless (file-exists-p file) - (error "No such file: %s" file)) - (unless (file-readable-p file) - (error "Permission denied: %s" file)) - file)) - -(defun message-mime-query-type (file) - (let* ((default (or (mm-default-file-encoding file) - ;; Perhaps here we should check what the file - ;; looks like, and offer text/plain if it looks - ;; like text/plain. - "application/octet-stream")) - (string (completing-read - (format "Content type (default %s): " default) - (delete-duplicates - (mapcar (lambda (m) (list (cdr m))) mailcap-mime-extensions) - :test 'equal)))) - (if (not (equal string "")) - string - default))) - -(defun message-mime-query-description () - (let ((description (read-string "One line description: "))) - (when (string-match "\\`[ \t]*\\'" description) - (setq description nil)) - description)) - -(defun message-mime-attach-file (file &optional type description) - "Attach a file to the outgoing MIME message. -The file is not inserted or encoded until you send the message with -`\\[message-send-and-exit]' or `\\[message-send]'. - -FILE is the name of the file to attach. TYPE is its content-type, a -string of the form \"type/subtype\". DESCRIPTION is a one-line -description of the attachment." - (interactive - (let* ((file (message-mime-query-file "Attach file: ")) - (type (message-mime-query-type file)) - (description (message-mime-query-description))) - (list file type description))) - (insert (format - "<#part type=%s filename=%s%s disposition=attachment><#/part>\n" - type (prin1-to-string file) - (if description - (format " description=%s" (prin1-to-string description)) - "")))) - -(defun message-mime-attach-external (file &optional type description) - "Attach an external file into the buffer. -FILE is an ange-ftp/efs specification of the part location. -TYPE is the MIME type to use." - (interactive - (let* ((file (message-mime-query-file "Attach external file: ")) - (type (message-mime-query-type file)) - (description (message-mime-query-description))) - (list file type description))) - (insert (format - "<#external type=%s name=%s disposition=attachment><#/external>\n" - type (prin1-to-string file)))) +(defvar message-inhibit-body-encoding t) (defun message-encode-message-body () - (let ((mm-default-charset message-default-charset) - lines multipart-p 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 multipart-p - (re-search-backward "^Content-Type: multipart/" nil t)) - (goto-char (point-max)) - (setq content-type-p - (re-search-backward "^Content-Type: multipart/" nil t))) - (save-restriction - (message-narrow-to-headers-or-head) - (message-remove-first-header "Content-Type") - (message-remove-first-header "Content-Transfer-Encoding")) - (when multipart-p + (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")) - (message-goto-body) - (insert "This is a MIME multipart message. If you are reading\n") - (insert "this, you shouldn't.\n")) - ;; 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")))) + ;; 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"))))) + +(defun message-read-from-minibuffer (prompt) + "Read from the minibuffer while providing abbrev expansion." + (if (fboundp 'mail-abbrevs-setup) + (let ((mail-abbrev-mode-regexp "") + (minibuffer-setup-hook 'mail-abbrevs-setup)) + (read-from-minibuffer prompt))) + (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)) + (read-string prompt))) (defvar message-save-buffer " *encoding") (defun message-save-drafts () @@ -4907,10 +5231,13 @@ TYPE is the MIME type to use." (if (not (get-buffer message-save-buffer)) (get-buffer-create message-save-buffer)) (let ((filename buffer-file-name) - (buffer (current-buffer))) + (buffer (current-buffer)) + (reply-headers message-reply-headers)) (set-buffer message-save-buffer) (erase-buffer) (insert-buffer buffer) + (setq message-reply-headers reply-headers) + (message-generate-headers '((optional . In-Reply-To))) (mime-edit-translate-buffer) (write-region (point-min) (point-max) filename) (set-buffer buffer)