X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=ead854d769367bb7765d508e1b36ccf940bff317;hb=cddb4672a1b8d0b3fb03dd1c5cad4b01f9fab219;hp=5c87339d2b7c8340076d83e30f58b7dcd6adcde5;hpb=0085ac597bba655e83a334e799dd04192c369a3a;p=elisp%2Fgnus.git- diff --git a/lisp/message.el b/lisp/message.el index 5c87339..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. @@ -252,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 @@ -324,7 +331,7 @@ should return the new buffer name." :group 'message-buffers :type '(choice (const :tag "off" nil) (const :tag "unique" unique) - (const :tag "unsuniqueent" unsent) + (const :tag "unsent" unsent) (function fun))) (defcustom message-kill-buffer-on-exit nil @@ -383,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 @@ -404,7 +411,7 @@ The provided functions are: :group 'message-forwarding :type 'boolean) -(defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus" +(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) @@ -426,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) @@ -568,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 @@ -576,11 +588,17 @@ the signature is inserted." :type 'hook) (defcustom message-bounce-setup-hook nil - "Normal hook, run each time a a re-sending bounced message is initialized. + "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 @@ -604,11 +622,16 @@ The function `message-bounce' runs this hook." ;;;###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'." @@ -622,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) @@ -751,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.") @@ -793,6 +816,11 @@ 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) + ;;; Internal variables. ;;; Well, not really internal. @@ -966,7 +994,7 @@ Defaults to `text-mode-abbrev-table'.") "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" "[:>|}].*") (0 'message-cited-text-face)) - ("<#/?\\(multi\\)part.*>" + ("<#/?\\(multipart\\|part\\|external\\).*>" (0 'message-mml-face)))) "Additional expressions to highlight in Message mode.") @@ -1016,17 +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) @@ -1111,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.") @@ -1136,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" @@ -1197,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." @@ -1228,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 @@ -1286,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) @@ -1358,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 () @@ -1389,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)))) - ;;; @@ -1442,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) @@ -1476,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] @@ -1532,8 +1582,8 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (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) @@ -1601,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)) @@ -1686,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." @@ -1791,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) @@ -1979,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. @@ -1989,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) @@ -2013,13 +2125,8 @@ prefix, and don't delete any headers." (if (listp message-indent-citation-function) message-indent-citation-function (list message-indent-citation-function))))) - (goto-char start) - ;; Quote parts. - (while (re-search-forward "<#/?!*\\(multi\\|part\\)>" end t) - (goto-char (match-beginning 1)) - (insert "!")) (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]*$") @@ -2034,7 +2141,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) @@ -2048,11 +2155,6 @@ prefix, and don't delete any headers." message-indent-citation-function (list message-indent-citation-function))))) (goto-char start) - ;; Quote parts. - (while (re-search-forward "<#/?!*\\(multi\\|part\\)>" end t) - (goto-char (match-beginning 1)) - (insert "!")) - (goto-char start) (while functions (funcall (pop functions))) (when message-citation-line-function @@ -2174,15 +2276,16 @@ The text will also be indented the normal way." (defun message-mimic-kill-buffer () "Kill the current buffer with query." (interactive) - (if (buffer-modified-p) - (message-kill-buffer) - (let ((command this-command) - (bufname (read-buffer (format "Kill buffer: (default %s) " - (buffer-name))))) - (if (or (not bufname) - (string-equal bufname (buffer-name))) - (message-kill-buffer) - (message "%s must be invoked only for the current buffer." command))))) + (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." @@ -2254,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." @@ -2297,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) @@ -2437,31 +2544,31 @@ This sub function is for exclusive use of `message-send-mail'." (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) @@ -2487,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) @@ -2651,12 +2758,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) )) @@ -2923,15 +3024,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." @@ -3429,7 +3527,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 @@ -3621,10 +3719,6 @@ 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 - ;; 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. ((eq message-generate-new-buffers 'unique) (generate-new-buffer-name @@ -3636,6 +3730,10 @@ Headers already prepared in the buffer are not modified." "") (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)) ((eq message-generate-new-buffers 'unsent) (generate-new-buffer-name (concat "*unsent " type @@ -3719,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. @@ -3781,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." @@ -3789,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)))))))) + ;;; @@ -3826,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. @@ -3857,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)) @@ -3887,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. @@ -4050,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. @@ -4183,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) @@ -4192,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. @@ -4225,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 () @@ -4276,7 +4407,7 @@ header line with the old Message-ID." (replace-match "")) (buffer-string))) - + ;;; Forwarding messages. (defun message-forward-subject-author-subject (subject) @@ -4303,14 +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 (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)) @@ -4331,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 @@ -4412,9 +4545,6 @@ Optional NEWS will use news to forward instead of mail." (message "Resending message to %s...done" address))) (defun message-bounce-setup-for-mime-edit () - (goto-char (point-min)) - (when (search-forward (concat "\n" mail-header-separator "\n") nil t) - (replace-match "\n\n")) (set (make-local-variable 'message-setup-hook) nil) (mime-edit-again)) @@ -4679,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!") @@ -4693,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 @@ -4729,40 +4865,51 @@ regexp varstr." ;;; MIME functions ;;; -(defun message-insert-mime-part (file type) - "Insert a multipart/alternative part into the buffer." - (interactive - (let* ((file (read-file-name "Insert file: " nil nil t)) - (type (mm-default-file-encoding file))) - (list file - (completing-read - (format "MIME type for %s: " file) - (mapcar (lambda (m) (list (cdr m))) mailcap-mime-extensions) - nil nil type)))) - (insert (format "<#part type=%s filename=\"%s\"><#/part>\n" - type file))) +(defvar message-inhibit-body-encoding t) (defun message-encode-message-body () - (message-goto-body) - (save-restriction - (narrow-to-region (point) (point-max)) - (let ((new (mml-generate-mime))) - (delete-region (point-min) (point-max)) - (insert new) - (goto-char (point-min)) - (widen) - (forward-line -1) - (let ((beg (point)) - (line (buffer-substring (point) (progn (forward-line 1) (point))))) - (delete-region beg (point)) - (insert "Mime-Version: 1.0\n") - (search-forward "\n\n") - (forward-char -1) - (insert line) - (when (save-excursion - (re-search-backward "^Content-Type: multipart/" nil t)) - (insert "This is a MIME multipart message. If you are reading\n") - (insert "this, you shouldn't.\n")))))) + (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 () @@ -4779,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