X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=40f581da875c29007ab491773efb036a09e2c519;hb=8ea1f15fd54f5a6b6bc71dd0b6c155ab77f474c1;hp=78c373e1fdc2d6908958627f7eb7caa6718ffd97;hpb=7490cf56064d2ca699cb7b1f560dd0654cb18e88;p=gnus diff --git a/lisp/message.el b/lisp/message.el index 78c373e1f..40f581da8 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -30,16 +30,16 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile + (require 'cl) + (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary + (require 'mailheader) (require 'nnheader) -(require 'easymenu) -(if (string-match "XEmacs\\|Lucid" emacs-version) - (require 'mail-abbrevs) - (require 'mailabbrev)) +;; This is apparently necessary even though things are autoloaded: +(if (featurep 'xemacs) + (require 'mail-abbrevs)) (require 'mail-parse) -(require 'mm-bodies) -(require 'mm-encode) (require 'mml) (defgroup message '((user-mail-address custom-variable) @@ -166,11 +166,12 @@ To disable checking of long signatures, for instance, add 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 -newsgroups." - :group 'message-news) +long-lines control-chars size new-text quoting-style +redirected-followup signature approved sender empty empty-headers +message-id from subject shorten-followup-to existing-newsgroups +buffer-file-name unchanged newsgroups." + :group 'message-news + :type '(repeat sexp)) (defcustom message-required-news-headers '(From Newsgroups Subject Date Message-ID @@ -319,7 +320,7 @@ The provided functions are: :group 'message-interface :type 'regexp) -(defcustom message-forward-ignored-headers "Content-Transfer-Encoding" +(defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus" "*All headers that match this regexp will be deleted when forwarding a message." :group 'message-forwarding :type '(choice (const :tag "None" nil) @@ -623,13 +624,10 @@ actually occur." :group 'message-sending :type 'sexp) -;; Ignore errors in case this is used in Emacs 19. -;; Don't use ignore-errors because this is copied into loaddefs.el. ;;;###autoload -(ignore-errors - (define-mail-user-agent 'message-user-agent - 'message-mail 'message-send-and-exit - 'message-kill-buffer 'message-send-hook)) +(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.") @@ -667,12 +665,15 @@ 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." +(defcustom message-default-charset + (and (not (mm-multibyte-p)) 'iso-8859-1) + "Default charset used in non-MULE Emacsen. +If nil, you might be asked to input the charset." :group 'message :type 'symbol) -(defcustom message-dont-reply-to-names rmail-dont-reply-to-names +(defcustom message-dont-reply-to-names + (and (boundp 'rmail-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 @@ -821,7 +822,7 @@ Defaults to `text-mode-abbrev-table'.") (defvar message-font-lock-keywords (let* ((cite-prefix "A-Za-z") (cite-suffix (concat cite-prefix "0-9_.@-")) - (content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)")) + (content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?")) `((,(concat "^\\([Tt]o:\\)" content) (1 'message-header-name-face) (2 'message-header-to-face nil t)) @@ -902,8 +903,16 @@ should be sent in several parts. If it is nil, the size is unlimited." :type '(choice (const :tag "unlimited" nil) (integer 1000000))) +(defcustom message-alternative-emails nil + "A regexp to match the alternative email addresses. +The first matched address (not primary one) is used in the From field." + :group 'message-headers + :type '(choice (const :tag "Always use primary" nil) + regexp)) + ;;; Internal variables. +(defvar message-sending-message "Sending...") (defvar message-buffer-list nil) (defvar message-this-is-news nil) (defvar message-this-is-mail nil) @@ -999,12 +1008,16 @@ should be sent in several parts. If it is nil, the size is unlimited." (User-Agent)) "Alist used for formatting headers.") +(defvar message-options nil + "Some saved answers when sending message.") + (eval-and-compile (autoload 'message-setup-toolbar "messagexmas") (autoload 'mh-new-draft-name "mh-comp") (autoload 'mh-send-letter "mh-comp") (autoload 'gnus-point-at-eol "gnus-util") (autoload 'gnus-point-at-bol "gnus-util") + (autoload 'gnus-output-to-rmail "gnus-util") (autoload 'gnus-output-to-mail "gnus-util") (autoload 'mail-abbrev-in-expansion-header-p "mailabbrev") (autoload 'nndraft-request-associate-buffer "nndraft") @@ -1012,6 +1025,7 @@ should be sent in several parts. If it is nil, the size is unlimited." (autoload 'gnus-open-server "gnus-int") (autoload 'gnus-request-post "gnus-int") (autoload 'gnus-alive-p "gnus-util") + (autoload 'gnus-group-name-charset "gnus-group") (autoload 'rmail-output "rmail")) @@ -1029,9 +1043,19 @@ should be sent in several parts. If it is nil, the size is unlimited." `(delete-region (progn (beginning-of-line) (point)) (progn (forward-line ,(or n 1)) (point)))) +(defun message-unquote-tokens (elems) + "Remove double quotes (\") from strings in list." + (mapcar (lambda (item) + (while (string-match "^\\(.*\\)\"\\(.*\\)$" item) + (setq item (concat (match-string 1 item) + (match-string 2 item)))) + item) + elems)) + (defun message-tokenize-header (header &optional separator) "Split HEADER into a list of header elements. -\",\" is used as the separator." +SEPARATOR is a string of characters to be used as separators. \",\" +is used by default." (if (not header) nil (let ((regexp (format "[%s]+" (or separator ","))) @@ -1061,7 +1085,7 @@ should be sent in several parts. If it is nil, the size is unlimited." ((and (eq (char-after) ?\)) (not quoted)) (setq paren nil)))) - (nreverse elems))))) + (nreverse elems))))) (defun message-mail-file-mbox-p (file) "Say whether FILE looks like a Unix mbox file." @@ -1081,8 +1105,8 @@ should be sent in several parts. If it is nil, the size is unlimited." (when value (while (string-match "\n[\t ]+" value) (setq value (replace-match " " t t value))) - ;; We remove all text props. - (format "%s" value)))) + (set-text-properties 0 (length value) nil value) + value))) (defun message-narrow-to-field () "Narrow the buffer to the header on the current line." @@ -1135,6 +1159,21 @@ should be sent in several parts. If it is nil, the size is unlimited." (and (listp form) (eq (car form) 'lambda)) (byte-code-function-p form))) +(defun message-strip-list-identifiers (subject) + "Remove list identifiers in `gnus-list-identifiers'." + (require 'gnus-sum) ; for gnus-list-identifiers + (let ((regexp (if (stringp gnus-list-identifiers) + gnus-list-identifiers + (mapconcat 'identity gnus-list-identifiers " *\\|")))) + (if (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp + " *\\)\\)+\\(Re: +\\)?\\)") subject) + (concat (substring subject 0 (match-beginning 1)) + (or (match-string 3 subject) + (match-string 5 subject)) + (substring subject + (match-end 1))) + subject))) + (defun message-strip-subject-re (subject) "Remove \"Re:\" from subject lines." (if (string-match message-subject-re-regexp subject) @@ -1412,6 +1451,8 @@ C-c C-r message-caesar-buffer-body (rot13 the message body). C-c C-a mml-attach-file (attach a file as MIME). M-RET message-newline-and-reformat (break the line and reformat)." (interactive) + (if (local-variable-p 'mml-buffer-list (current-buffer)) + (mml-destroy-buffers)) (kill-all-local-variables) (set (make-local-variable 'message-reply-buffer) nil) (make-local-variable 'message-send-actions) @@ -1436,20 +1477,6 @@ M-RET message-newline-and-reformat (break the line and reformat)." (error "Face %s not configured for %s mode" face mode-name))) "") facemenu-remove-face-function t) - (make-local-variable 'paragraph-separate) - (make-local-variable 'paragraph-start) - ;; `-- ' precedes the signature. `-----' appears at the start of the - ;; lines that delimit forwarded messages. - ;; Lines containing just >= 3 dashes, perhaps after whitespace, - ;; are also sometimes used and should be separators. - (setq paragraph-start - (concat (regexp-quote mail-header-separator) - "$\\|[ \t]*[a-z0-9A-Z]*>+[ \t]*$\\|[ \t]*$\\|" - "-- $\\|---+$\\|" - page-delimiter - ;;!!! Uhm... shurely this can't be right? - "[> " (regexp-quote message-yank-prefix) "]+$")) - (setq paragraph-separate paragraph-start) (make-local-variable 'message-reply-headers) (setq message-reply-headers nil) (make-local-variable 'message-newsreader) @@ -1458,10 +1485,13 @@ M-RET message-newline-and-reformat (break the line and reformat)." (set (make-local-variable 'message-sent-message-via) nil) (set (make-local-variable 'message-checksum) nil) (set (make-local-variable 'message-mime-part) 0) + (message-setup-fill-variables) ;;(when (fboundp 'mail-hist-define-keys) ;; (mail-hist-define-keys)) - (when (string-match "XEmacs\\|Lucid" emacs-version) - (message-setup-toolbar)) + (if (featurep 'xemacs) + (message-setup-toolbar) + (set (make-local-variable 'font-lock-defaults) + '(message-font-lock-keywords t))) (easy-menu-add message-mode-menu message-mode-map) (easy-menu-add message-mode-field-menu message-mode-map) ;; Allow mail alias things. @@ -1470,26 +1500,45 @@ M-RET message-newline-and-reformat (break the line and reformat)." (mail-abbrevs-setup) (mail-aliases-setup))) (message-set-auto-save-file-name) - (unless (string-match "XEmacs" emacs-version) - (set (make-local-variable 'font-lock-defaults) - '(message-font-lock-keywords t))) - (make-local-variable 'adaptive-fill-regexp) - (setq 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]*\\)+[ \t]*\\|" - adaptive-fill-first-line-regexp)) - (make-local-variable 'auto-fill-inhibit-regexp) - (setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:") (mm-enable-multibyte) (make-local-variable 'indent-tabs-mode) ;Turn off tabs for indentation. (setq indent-tabs-mode nil) (mml-mode) (run-hooks 'text-mode-hook 'message-mode-hook)) +(defun message-setup-fill-variables () + "Setup message fill variables." + (make-local-variable 'paragraph-separate) + (make-local-variable 'paragraph-start) + (make-local-variable '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) + (make-local-variable 'auto-fill-inhibit-regexp) + (let ((quote-prefix-regexp + (concat + "[ \t]*" ; possible initial space + "\\(\\(" (regexp-quote message-yank-prefix) "\\|" ; user's prefix + "\\w+>\\|" ; supercite-style prefix + "[|:>]" ; standard prefix + "\\)[ \t]*\\)+"))) ; possible space after each prefix + (setq paragraph-start + (concat + (regexp-quote mail-header-separator) "$\\|" + "[ \t]*$\\|" ; blank lines + "-- $\\|" ; signature delimiter + "---+$\\|" ; delimiters for forwarded messages + page-delimiter "$\\|" ; spoiler warnings + ".*wrote:$\\|" ; attribution lines + quote-prefix-regexp "$")) ; empty lines in quoted text + (setq paragraph-separate paragraph-start) + (setq adaptive-fill-regexp + (concat quote-prefix-regexp "\\|" adaptive-fill-regexp)) + (setq adaptive-fill-first-line-regexp + (concat quote-prefix-regexp "\\|" + adaptive-fill-first-line-regexp)) + (setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:"))) + ;;; @@ -1596,7 +1645,8 @@ With the prefix argument FORCE, insert the header anyway." (mail-fetch-field "to") (not (string-match "\\` *\\'" (mail-fetch-field "to")))) (insert ", ")) - (insert (or (message-fetch-reply-field "reply-to") + (insert (or (message-fetch-reply-field "mail-reply-to") + (message-fetch-reply-field "reply-to") (message-fetch-reply-field "from") ""))) (defun message-widen-reply () @@ -1667,7 +1717,7 @@ With the prefix argument FORCE, insert the header anyway." (unless (bolp) (save-excursion (beginning-of-line) - (when (looking-at (concat prefix + (when (looking-at (concat prefix "\\|" supercite-thing)) (setq quoted (match-string 0)))) (insert "\n")) @@ -2075,21 +2125,23 @@ It should typically alter the sending method in some way or other." (put-text-property (point-min) (point-max) 'read-only nil)) (message-fix-before-sending) (run-hooks 'message-send-hook) - (message "Sending...") + (message message-sending-message) (let ((alist message-send-method-alist) (success t) - elem sent) + elem sent + (message-options message-options)) + (message-options-set-recipient) (while (and success (setq elem (pop alist))) - (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 (funcall (cadr elem)) + (when (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)))) (unless (or sent (not success)) (error "No methods specified to send by")) (when (and success sent) @@ -2161,6 +2213,12 @@ It should typically alter the sending method in some way or other." (defun message-send-mail-partially () "Sendmail as message/partial." + ;; replace the header delimiter with a blank line + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (run-hooks 'message-send-mail-hook) (let ((p (goto-char (point-min))) (tembuf (message-generate-new-buffer-clone-locals " message temp")) (curbuf (current-buffer)) @@ -2171,7 +2229,7 @@ It should typically alter the sending method in some way or other." (goto-char (point-max)) (goto-char (+ p message-send-mail-partially-limit)) (beginning-of-line) - (if (<= (point) p) (end-of-line))) ;; In case of bad message. + (if (<= (point) p) (forward-line 1))) ;; In case of bad message. (push p plist) (setq p (point))) (setq total (length plist)) @@ -2218,7 +2276,8 @@ It should typically alter the sending method in some way or other." (goto-char (point-max)) (insert "\n") (widen) - (funcall message-send-mail-function)) + (mm-with-unibyte-current-buffer + (funcall message-send-mail-function))) (setq n (+ n 1)) (setq p (pop plist)) (erase-buffer))) @@ -2261,19 +2320,28 @@ It should typically alter the sending method in some way or other." (message-generate-headers '(Lines))) ;; Remove some headers. (message-remove-header message-ignored-mail-headers t) - (mail-encode-encoded-word-buffer)) + (let ((mail-parse-charset message-default-charset)) + (mail-encode-encoded-word-buffer))) (goto-char (point-max)) ;; require one newline at the end. (or (= (preceding-char) ?\n) (insert ?\n)) - (when (and news + (when + (save-restriction + (message-narrow-to-headers) + (and news (or (message-fetch-field "cc") - (message-fetch-field "to"))) + (message-fetch-field "to")) + (string= "text/plain" + (car + (mail-header-parse-content-type + (message-fetch-field "content-type")))))) (message-insert-courtesy-copy)) (if (or (not message-send-mail-partially-limit) (< (point-max) message-send-mail-partially-limit) (not (y-or-n-p "The message size is too large, should it be sent partially?"))) - (funcall message-send-mail-function) + (mm-with-unibyte-current-buffer + (funcall message-send-mail-function)) (message-send-mail-partially))) (kill-buffer tembuf)) (set-buffer mailbuf) @@ -2410,6 +2478,12 @@ to find out how to use this." (method (if (message-functionp message-post-method) (funcall message-post-method arg) message-post-method)) + (group-name-charset (gnus-group-name-charset method "")) + (rfc2047-header-encoding-alist + (if group-name-charset + (cons (cons "Newsgroups" group-name-charset) + rfc2047-header-encoding-alist) + rfc2047-header-encoding-alist)) (messbuf (current-buffer)) (message-syntax-checks (if arg @@ -2418,7 +2492,9 @@ to find out how to use this." message-syntax-checks)) (message-this-is-news t) (message-posting-charset (gnus-setup-posting-charset - (message-fetch-field "Newsgroups"))) + (save-restriction + (message-narrow-to-headers-or-head) + (message-fetch-field "Newsgroups")))) result) (if (not (message-check-news-body-syntax)) nil @@ -2428,6 +2504,10 @@ to find out how to use this." (message-generate-headers message-required-news-headers) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) + (if group-name-charset + (setq message-syntax-checks + (cons '(valid-newsgroups . disabled) + message-syntax-checks))) (message-cleanup-headers) (if (not (message-check-news-syntax)) nil @@ -2450,7 +2530,7 @@ to find out how to use this." (message-generate-headers '(Lines))) ;; Remove some headers. (message-remove-header message-ignored-news-headers t) - (let ((mail-parse-charset (car message-posting-charset))) + (let ((mail-parse-charset message-default-charset)) (mail-encode-encoded-word-buffer))) (goto-char (point-max)) ;; require one newline at the end. @@ -2746,7 +2826,20 @@ to find out how to use this." (format "Your .sig is %d lines; it should be max 4. Really post? " (1- (count-lines (point) (point-max))))) - t)))) + t)) + ;; Ensure that text follows last quoted portion. + (message-check 'quoting-style + (goto-char (point-max)) + (let ((no-problem t)) + (when (search-backward-regexp "^>[^\n]*\n>" nil t) + (setq no-problem nil) + (while (not (eobp)) + (when (and (not (eolp)) (looking-at "[^> \t]")) + (setq no-problem t)) + (forward-line))) + (if no-problem + t + (y-or-n-p "Your text should follow quoted text. Really post? ")))))) (defun message-checksum () "Return a \"checksum\" for the current buffer." @@ -2776,9 +2869,19 @@ to find out how to use this." (while (setq file (message-fetch-field "fcc")) (push file list) (message-remove-header "fcc" nil t))) + (message-encode-message-body) + (save-restriction + (message-narrow-to-headers) + (let ((mail-parse-charset message-default-charset) + (rfc2047-header-encoding-alist + (cons '("Newsgroups" . default) + rfc2047-header-encoding-alist))) + (mail-encode-encoded-word-buffer))) (goto-char (point-min)) - (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) - (replace-match "" t t) + (when (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$") + nil t) + (replace-match "" t t )) ;; Process FCC operations. (while list (setq file (pop list)) @@ -2798,14 +2901,13 @@ 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) "Append this article to Unix/babyl mail file.." (if (and (file-readable-p filename) (mail-file-babyl-p filename)) - (rmail-output-to-rmail-file filename t) + (gnus-output-to-rmail filename t) (gnus-output-to-mail filename t))) (defun message-cleanup-headers () @@ -2955,18 +3057,7 @@ If NOW, use that time instead." (defun message-make-in-reply-to () "Return the In-Reply-To header for this message." (when message-reply-headers - (let ((from (mail-header-from message-reply-headers)) - (date (mail-header-date message-reply-headers))) - (when from - (let ((stop-pos - (string-match " *at \\| *@ \\| *(\\| *<" from))) - (concat (if (and stop-pos - (not (zerop stop-pos))) - (substring from 0 stop-pos) from) - "'s message of \"" - (if (or (not date) (string= date "")) - "(unknown date)" date) - "\"")))))) + (mail-header-message-id message-reply-headers))) (defun message-make-distribution () "Make a Distribution header." @@ -3509,6 +3600,8 @@ than 988 characters long, and if they are not, trim them until they are." (message-insert-signature) (save-restriction (message-narrow-to-headers) + (if message-alternative-emails + (message-use-alternative-email-as-from)) (run-hooks 'message-header-setup-hook)) (set-buffer-modified-p nil) (setq buffer-undo-list nil) @@ -3581,13 +3674,15 @@ OTHER-HEADERS is an alist of header/value pairs." (Subject . ,(or subject "")))))) (defun message-get-reply-headers (wide &optional to-address) - (let (follow-to mct never-mct from to cc reply-to ccalist) + (let (follow-to mct never-mct from to cc reply-to mrt mft ccalist) ;; Find all relevant headers we need. (setq from (message-fetch-field "from") to (message-fetch-field "to") cc (message-fetch-field "cc") mct (message-fetch-field "mail-copies-to") - reply-to (message-fetch-field "reply-to")) + reply-to (message-fetch-field "reply-to") + mrt (message-fetch-field "mail-reply-to") + mft (message-fetch-field "mail-followup-to")) ;; Handle special values of Mail-Copies-To. (when mct @@ -3597,22 +3692,44 @@ OTHER-HEADERS is an alist of header/value pairs." (setq mct nil)) ((or (equal (downcase mct) "always") (equal (downcase mct) "poster")) - (setq mct (or reply-to from))))) + (setq mct (or mrt reply-to from))))) (if (or (not wide) to-address) (progn - (setq follow-to (list (cons 'To (or to-address reply-to from)))) - (when (and wide mct) - (push (cons 'Cc mct) follow-to))) + (setq follow-to (list (cons 'To (or to-address mrt reply-to from)))) + (when (and wide (or mft mct)) + (push (cons 'Cc (or mft mct)) follow-to))) (let (ccalist) (save-excursion (message-set-work-buffer) - (unless never-mct - (insert (or reply-to from ""))) - (insert (if to (concat (if (bolp) "" ", ") to "") "")) - (insert (if mct (concat (if (bolp) "" ", ") mct) "")) - (insert (if cc (concat (if (bolp) "" ", ") cc) "")) + (if (and mft + message-use-followup-to + (or (not (eq message-use-followup-to 'ask)) + (message-y-or-n-p + (concat "Obey Mail-Followup-To? ") t "\ +You should normally obey the Mail-Followup-To: header. In this +article, it has the value of + +" mft " + +which directs your response to " (if (string-match "," mft) + "the specified addresses" + "that address only") ". + +If a message is posted to several mailing lists, Mail-Followup-To is +often used to direct the following discussion to one list only, +because discussions that are spread over several lists tend to be +fragmented and very difficult to follow. + +Also, some source/announcement lists are not indented for discussion; +responses here are directed to other addresses."))) + (insert mft) + (unless never-mct + (insert (or mrt reply-to from ""))) + (insert (if to (concat (if (bolp) "" ", ") to "") "")) + (insert (if mct (concat (if (bolp) "" ", ") mct) "")) + (insert (if cc (concat (if (bolp) "" ", ") cc) ""))) (goto-char (point-min)) (while (re-search-forward "[ \t]+" nil t) (replace-match " " t t)) @@ -3623,7 +3740,7 @@ OTHER-HEADERS is an alist of header/value pairs." (goto-char (point-min)) ;; Perhaps "Mail-Copies-To: never" removed the only address? (when (eobp) - (insert (or reply-to from ""))) + (insert (or mrt reply-to from ""))) (setq ccalist (mapcar (lambda (addr) @@ -3641,11 +3758,11 @@ OTHER-HEADERS is an alist of header/value pairs." (push ccs follow-to))))) follow-to)) - ;;;###autoload (defun message-reply (&optional to-address wide) "Start editing a reply to the article in the current buffer." (interactive) + (require 'gnus-sum) ; for gnus-list-identifiers (let ((cur (current-buffer)) from subject date reply-to to cc references message-id follow-to @@ -3669,11 +3786,9 @@ OTHER-HEADERS is an alist of header/value pairs." date (message-fetch-field "date") from (message-fetch-field "from") subject (or (message-fetch-field "subject") "none")) - ;; Remove any (buggy) Re:'s that are present and make a - ;; proper one. - (when (string-match message-subject-re-regexp subject) - (setq subject (substring subject (match-end 0)))) - (setq subject (concat "Re: " subject)) + (if gnus-list-identifiers + (setq subject (message-strip-list-identifiers subject))) + (setq subject (concat "Re: " (message-strip-subject-re subject))) (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) (string-match "<[^>]+>" gnus-warning)) @@ -3710,8 +3825,9 @@ OTHER-HEADERS is an alist of header/value pairs." "Follow up to the message in the current buffer. If TO-NEWSGROUPS, use that as the new Newsgroups line." (interactive) + (require 'gnus-sum) ; for gnus-list-identifiers (let ((cur (current-buffer)) - from subject date reply-to mct + from subject date reply-to mrt mct references message-id follow-to (inhibit-point-motion-hooks t) (message-this-is-news t) @@ -3734,6 +3850,7 @@ If TO-NEWSGROUPS, use that as the new Newsgroups line." newsgroups (message-fetch-field "newsgroups") posted-to (message-fetch-field "posted-to") reply-to (message-fetch-field "reply-to") + mrt (message-fetch-field "mail-reply-to") distribution (message-fetch-field "distribution") mct (message-fetch-field "mail-copies-to")) (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) @@ -3744,11 +3861,9 @@ If TO-NEWSGROUPS, use that as the new Newsgroups line." (let ((case-fold-search t)) (string-match "world" distribution))) (setq distribution nil)) - ;; Remove any (buggy) Re:'s that are present and make a - ;; proper one. - (when (string-match message-subject-re-regexp subject) - (setq subject (substring subject (match-end 0)))) - (setq subject (concat "Re: " subject)) + (if gnus-list-identifiers + (setq subject (message-strip-list-identifiers subject))) + (setq subject (concat "Re: " (message-strip-subject-re subject))) (widen)) (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) @@ -3773,7 +3888,7 @@ A typical situation where `Followup-To: poster' is used is when the poster does not read the newsgroup, so he wouldn't see any replies sent to it.")) (progn (setq message-this-is-news nil) - (cons 'To (or reply-to from ""))) + (cons 'To (or mrt reply-to from ""))) (cons 'Newsgroups newsgroups))) (t (if (or (equal followup-to newsgroups) @@ -3809,7 +3924,7 @@ responses here are directed to other newsgroups.")) (equal (downcase mct) "nobody")))) (list (cons 'Cc (if (or (equal (downcase mct) "always") (equal (downcase mct) "poster")) - (or reply-to from "") + (or mrt reply-to from "") mct))))) cur) @@ -3852,7 +3967,7 @@ If ARG, allow editing of the cancellation message." (setq buf (set-buffer (get-buffer-create " *message cancel*")))) (erase-buffer) (insert "Newsgroups: " newsgroups "\n" - "From: " (message-make-from) "\n" + "From: " from "\n" "Subject: cmsg cancel " message-id "\n" "Control: cancel " message-id "\n" (if distribution @@ -3891,6 +4006,7 @@ header line with the old Message-ID." ;; Get a normal message buffer. (message-pop-to-buffer (message-buffer-name "supersede")) (insert-buffer-substring cur) + (mime-to-mml) (message-narrow-to-head) ;; Remove unwanted headers. (when message-ignored-supersedes-headers @@ -3999,9 +4115,10 @@ the message." subject)))) ;;;###autoload -(defun message-forward (&optional news) +(defun message-forward (&optional news digest) "Forward the current message via mail. -Optional NEWS will use news to forward instead of mail." +Optional NEWS will use news to forward instead of mail. +Optional DIGEST will use digest to forward." (interactive "P") (let* ((cur (current-buffer)) (subject (if message-forward-show-mml @@ -4018,32 +4135,43 @@ Optional NEWS will use news to forward instead of mail." (message-goto-body) (goto-char (point-max))) (if message-forward-as-mime - (if message-forward-show-mml - (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n") - (insert "\n\n<#part type=message/rfc822 disposition=inline" - " buffer=\"" (buffer-name cur) "\">\n")) + (if digest + (insert "\n<#multipart type=digest>\n") + (if message-forward-show-mml + (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n") + (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n"))) (insert "\n-------------------- Start of forwarded message --------------------\n")) - (let ((b (point)) - e) - (if message-forward-show-mml - (insert-buffer-substring cur) - (unless message-forward-as-mime + (let ((b (point)) e) + (if digest + (if message-forward-as-mime + (insert-buffer-substring cur) + (mml-insert-buffer cur)) + (if message-forward-show-mml + (insert-buffer-substring cur) (mml-insert-buffer cur))) (setq e (point)) (if message-forward-as-mime - (if message-forward-show-mml - (insert "<#/mml>\n") - (insert "<#/part>\n")) + (if digest + (insert "<#/multipart>\n") + (if message-forward-show-mml + (insert "<#/mml>\n") + (insert "<#/part>\n"))) (insert "\n-------------------- End of forwarded message --------------------\n")) - (when (and (or message-forward-show-mml - (not message-forward-as-mime)) - (not current-prefix-arg) - message-forward-ignored-headers) - (save-restriction - (narrow-to-region b e) - (goto-char b) - (narrow-to-region (point) (or (search-forward "\n\n" nil t) (point))) - (message-remove-header message-forward-ignored-headers t)))) + (if (and digest message-forward-as-mime) + (save-restriction + (narrow-to-region b e) + (goto-char b) + (narrow-to-region (point) + (or (search-forward "\n\n" nil t) (point))) + (delete-region (point-min) (point-max))) + (when (and (not current-prefix-arg) + message-forward-ignored-headers) + (save-restriction + (narrow-to-region b e) + (goto-char b) + (narrow-to-region (point) + (or (search-forward "\n\n" nil t) (point))) + (message-remove-header message-forward-ignored-headers t))))) (message-position-point))) ;;;###autoload @@ -4098,7 +4226,7 @@ Optional NEWS will use news to forward instead of mail." ;;;###autoload (defun message-bounce () "Re-mail the current message. -This only makes sense if the current message is a bounce message than +This only makes sense if the current message is a bounce message that contains some mail you have written which has been bounced back to you." (interactive) @@ -4123,6 +4251,8 @@ you." (if (re-search-forward "^[^ \n\t]+:" nil t) (match-beginning 0) (point)))) + (mm-enable-multibyte) + (mime-to-mml) (save-restriction (message-narrow-to-head) (message-remove-header message-ignored-bounced-headers t) @@ -4225,7 +4355,7 @@ which specify the range to operate on." (defalias 'message-exchange-point-and-mark 'exchange-point-and-mark) ;; Support for toolbar -(when (string-match "XEmacs\\|Lucid" emacs-version) +(when (featurep 'xemacs) (require 'messagexmas)) ;;; Group name completion. @@ -4345,18 +4475,8 @@ regexp varstr." ;;; Miscellaneous functions -;; stolen (and renamed) from nnheader.el -(defun message-replace-chars-in-string (string from to) - "Replace characters in STRING from FROM to TO." - (let ((string (substring string 0)) ;Copy string. - (len (length string)) - (idx 0)) - ;; Replace all occurrences of FROM with TO. - (while (< idx len) - (when (= (aref string idx) from) - (aset string idx to)) - (setq idx (1+ idx))) - string)) +(defsubst message-replace-chars-in-string (string from to) + (mm-subst-char-in-string from to string)) ;;; ;;; MIME functions @@ -4412,9 +4532,50 @@ regexp varstr." (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))) + (read-from-minibuffer prompt)) + (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)) + (read-string prompt)))) + +(defun message-use-alternative-email-as-from () + (require 'mail-utils) + (let* ((fields '("To" "Cc")) + (emails + (split-string + (mail-strip-quoted-names + (mapconcat 'message-fetch-reply-field fields ",")) + "[ \f\t\n\r\v,]+")) + email) + (while emails + (if (string-match message-alternative-emails (car emails)) + (setq email (car emails) + emails nil)) + (pop emails)) + (unless (or (not email) (equal email user-mail-address)) + (goto-char (point-max)) + (insert "From: " email "\n")))) + +(defun message-options-get (symbol) + (cdr (assq symbol message-options))) + +(defun message-options-set (symbol value) + (let ((the-cons (assq symbol message-options))) + (if the-cons + (if value + (setcdr the-cons value) + (setq message-options (delq the-cons message-options))) + (and value + (push (cons symbol value) message-options)))) + value) + +(defun message-options-set-recipient () + (save-restriction + (message-narrow-to-headers-or-head) + (message-options-set 'message-sender + (mail-strip-quoted-names + (message-fetch-field "from"))) + (message-options-set 'message-recipients + (mail-strip-quoted-names + (message-fetch-field "to"))))) (provide 'message)