X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=124c154995e366cf1c2cea827c0e3af9a5a88dcb;hb=7487c624068b6078a702adeec9a3a869aa0186bb;hp=27c419df0c5f8c07ae077c4350f9da85cd397a5d;hpb=cd13ede00e34997d48de2589ea45c0d6a62cf7c4;p=elisp%2Fgnus.git- diff --git a/lisp/message.el b/lisp/message.el index 27c419d..124c154 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -1,5 +1,6 @@ ;;; message.el --- composing mail and news messages -;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2000 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -35,26 +36,23 @@ ;;; Code: -(eval-when-compile (require 'cl)) -(eval-when-compile (require 'smtp)) +(eval-when-compile + (require 'cl) + (require 'smtp) + (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary (require 'mailheader) (require 'nnheader) -(require 'easymenu) -(require 'custom) -(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 'mime-edit) (eval-when-compile (require 'static)) ;; Avoid byte-compile warnings. (eval-when-compile (require 'mail-parse) - (require 'mm-bodies) - (require 'mm-encode) - (require 'mml) - ) + (require 'mml)) (defgroup message '((user-mail-address custom-variable) (user-full-name custom-variable)) @@ -199,11 +197,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 @@ -246,7 +245,7 @@ included. Organization, Lines and User-Agent are optional." :group 'message-headers :type 'regexp) -(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:" +(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:" "*Header lines matching this regexp will be deleted before posting. It's best to delete old Path and Date headers before posting to avoid any confusion." @@ -379,11 +378,6 @@ If t, use `message-user-organization-file'." :group 'message-forwarding :type 'string) -(defcustom message-signature-before-forwarded-message t - "*If non-nil, put the signature before any included forwarded message." - :group 'message-forwarding - :type 'boolean) - (defcustom message-included-forward-headers "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^\\(Mail-\\)?Followup-To:\\|^\\(Mail-\\)?Reply-To:\\|^Mail-Copies-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-\\|^MIME-Version:" "*Regexp matching headers to be included in forwarded messages." @@ -411,6 +405,16 @@ The provided functions are: :group 'message-forwarding :type 'boolean) +(defcustom message-forward-show-mml t + "*If non-nil, forward messages are shown as mml. Otherwise, forward messages are unchanged." + :group 'message-forwarding + :type 'boolean) + +(defcustom message-forward-before-signature t + "*If non-nil, put forwarded message before signature, else after." + :group 'message-forwarding + :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 @@ -421,7 +425,7 @@ The provided functions are: :group 'message-interface :type 'regexp) -(defcustom message-forward-ignored-headers nil +(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) @@ -432,7 +436,14 @@ The provided functions are: :group 'message-insertion :type 'regexp) -(defcustom message-cancel-message "I am canceling my own article." +(defcustom message-cite-prefix-regexp + ;; ?-, ?_ or ?. MUST NOT be in syntax entry w. + "[ \t]*\\(\\(\\w\\|[-_.]\\)+>+[ \t]*\\|[]>»|:}+][ \t]*\\)+" + "*Regexp matching the longest possible citation prefix on a line." + :group 'message-insertion + :type 'regexp) + +(defcustom message-cancel-message "I am canceling my own article.\n" "Message to be inserted in the cancel message." :group 'message-interface :type 'string) @@ -799,13 +810,13 @@ actually occur." (defvar message-user-agent nil "String of the form of PRODUCT/VERSION. Used for User-Agent header field.") -;; Ignore errors in case this is used in Emacs 19. -;; Don't use ignore-errors because this is copied into loaddefs.el. +(static-when (boundp 'MULE) + (require 'reporter));; `define-mail-user-agent' is here. + ;;;###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.") @@ -843,12 +854,14 @@ Valid valued are `unique' and `unsent'." :type '(choice (const :tag "unique" unique) (const :tag "unsent" unsent))) -(defcustom message-default-charset nil +(defcustom message-default-charset + (and (featurep 'xemacs) (not (featurep 'mule)) 'iso-8859-1) "Default charset used in non-MULE XEmacsen." :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 @@ -1139,7 +1152,7 @@ See also the documentations for the following variables: (setq message-font-lock-last-position nil))) (defvar message-font-lock-keywords-1 - (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)")) + (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?")) `((,(concat "^\\([Tt]o:\\)" content) (1 'message-header-name-face) (2 'message-header-to-face nil t)) @@ -1169,10 +1182,12 @@ See also the documentations for the following variables: (defvar message-font-lock-keywords-2 (append message-font-lock-keywords-1 - '((message-font-lock-cited-text-matcher + `((message-font-lock-cited-text-matcher (1 'message-cited-text-face) (2 'message-cited-text-face)) - ("<#/?\\(multipart\\|part\\|external\\).*>" + (,(concat "^\\(" message-cite-prefix-regexp "\\).*") + (0 'message-cited-text-face)) + ("<#/?\\(multipart\\|part\\|external\\|mml\\).*>" (0 'message-mml-face))))) (defvar message-font-lock-keywords message-font-lock-keywords-2 @@ -1241,8 +1256,24 @@ The cdr of ech entry is a function for applying the face to a region.") (t nil)) "Coding system to compose mail.") +(defcustom message-send-mail-partially-limit 1000000 + "The limitation of messages sent as message/partial. +The lower bound of message size in characters, beyond which the message +should be sent in several parts. If it is nil, the size is unlimited." + :group 'message-buffers + :type '(choice (const :tag "unlimited" nil) + (integer 1000000))) + +(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) @@ -1338,12 +1369,16 @@ The cdr of ech entry is a function for applying the face to a region.") (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") @@ -1352,6 +1387,7 @@ The cdr of ech entry is a function for applying the face to a region.") (autoload 'gnus-request-post "gnus-int") (autoload 'gnus-copy-article-buffer "gnus-msg") (autoload 'gnus-alive-p "gnus-util") + (autoload 'gnus-group-name-charset "gnus-group") (autoload 'rmail-output "rmail") (autoload 'mu-cite-original "mu-cite")) @@ -1386,9 +1422,19 @@ The cdr of ech entry is a function for applying the face to a region.") `(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 ","))) @@ -1418,7 +1464,7 @@ The cdr of ech entry is a function for applying the face to a region.") ((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." @@ -1433,12 +1479,13 @@ The cdr of ech entry is a function for applying the face to a region.") (defun message-fetch-field (header &optional not-all) "The same as `mail-fetch-field', only remove all newlines." (let* ((inhibit-point-motion-hooks t) + (case-fold-search t) (value (mail-fetch-field header nil (not not-all)))) (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." @@ -1491,6 +1538,21 @@ The cdr of ech entry is a function for applying the face to a region.") (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) @@ -1799,20 +1861,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-user-agent) @@ -1822,10 +1870,18 @@ M-RET message-newline-and-reformat (break the line and reformat)." (make-local-variable 'message-parameter-alist) (setq message-parameter-alist (copy-sequence message-startup-parameter-alist)) + (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 + 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) (easy-menu-add message-mode-menu message-mode-map) (easy-menu-add message-mode-field-menu message-mode-map) ;; Allow mail alias things. @@ -1834,27 +1890,42 @@ 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 - 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 'indent-tabs-mode) ;Turn off tabs for indentation. + (setq indent-tabs-mode nil) + (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) - (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 'indent-tabs-mode) ;Turn off tabs for indentation. - (setq indent-tabs-mode nil) - (run-hooks 'text-mode-hook 'message-mode-hook)) + (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]+:"))) @@ -1992,9 +2063,28 @@ 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 () + "Widen the reply to include maximum recipients." + (interactive) + (let ((follow-to + (and message-reply-buffer + (buffer-name message-reply-buffer) + (save-excursion + (set-buffer message-reply-buffer) + (message-get-reply-headers t))))) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (dolist (elem follow-to) + (message-remove-header (symbol-name (car elem))) + (goto-char (point-min)) + (insert (symbol-name (car elem)) ": " + (cdr elem) "\n")))))) + (defun message-insert-newsgroups () "Insert the Newsgroups header from the article being replied to." (interactive) @@ -2039,14 +2129,11 @@ 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 ((prefix "[]>»|:}+ \t]*") - (supercite-thing "[-._a-zA-Z0-9]*[>]+[ \t]*") - quoted point) + (let (quoted point) (unless (bolp) (save-excursion (beginning-of-line) - (when (looking-at (concat prefix - supercite-thing)) + (when (looking-at message-cite-prefix-regexp) (setq quoted (match-string 0)))) (insert "\n")) (setq point (point)) @@ -2122,14 +2209,7 @@ text was killed." (/= (aref message-caesar-translation-table ?a) (+ ?a n))) (setq message-caesar-translation-table (message-make-caesar-translation-table n))) - ;; Then we translate the region. Do it this way to retain - ;; text properties. - (while (< b e) - (when (< (char-after b) 255) - (subst-char-in-region - b (1+ b) (char-after b) - (aref message-caesar-translation-table (char-after b)))) - (incf b)))) + (translate-region b e message-caesar-translation-table))) (defun message-make-caesar-translation-table (n) "Create a rot table with offset N." @@ -2166,11 +2246,8 @@ Mail and USENET news headers are not rotated." (save-restriction (when (message-goto-body) (narrow-to-region (point) (point-max))) - (let ((body (buffer-substring (point-min) (point-max)))) - (unless (equal 0 (call-process-region - (point-min) (point-max) program t t)) - (insert body) - (message "%s failed" program)))))) + (shell-command-on-region + (point-min) (point-max) program nil t)))) (defun message-rename-buffer (&optional enter-string) "Rename the *message* buffer to \"*message* RECIPIENT\". @@ -2237,7 +2314,7 @@ However, if `message-yank-prefix' is non-nil, insert that prefix on each line." (message-delete-line)) ;; Delete blank lines at the end of the buffer. (goto-char (point-max)) - (unless (eolp) + (unless (bolp) (insert "\n")) (while (and (zerop (forward-line -1)) (looking-at "$")) @@ -2261,28 +2338,19 @@ to REFS-LIST." (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))))) + (push (pop refs-list) saved-id) + (setq pos (1- pos))))) (while refs-strs - (setq refs (car refs-strs) - refs-strs (cdr refs-strs)) - (when refs + (when (setq refs (pop refs-strs)) (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) "") - ">")) + (when (eq (car (setq ref (pop refs))) 'msg-id) + (setq id (concat "<" (mapconcat 'cdr (cdr ref) "") ">")) (or (member id refs-list) + (member id saved-id) (push id refs-list)))))) (while saved-id - (setq refs-list (cons (car saved-id) refs-list) - saved-id (cdr saved-id))) + (push (pop saved-id) refs-list)) refs-list)) (defvar gnus-article-copy) @@ -2378,6 +2446,8 @@ be added to \"References\" field. (if (listp message-indent-citation-function) message-indent-citation-function (list message-indent-citation-function))))) + ;; Allow undoing. + (undo-boundary) (goto-char end) (when (re-search-backward message-signature-separator start t) ;; Also peel off any blank lines before the signature. @@ -2406,7 +2476,18 @@ be added to \"References\" field. (when message-indent-citation-function (if (listp message-indent-citation-function) message-indent-citation-function - (list message-indent-citation-function))))) + (list message-indent-citation-function)))) + (message-reply-headers (or message-reply-headers + (make-mail-header)))) + (mail-header-set-from message-reply-headers + (save-restriction + (narrow-to-region + (point) + (if (search-forward "\n\n" nil t) + (1- (point)) + (point-max))) + (or (message-fetch-field "from") + "unknown sender"))) (goto-char start) (while functions (funcall (pop functions))) @@ -2587,31 +2668,33 @@ It should typically alter the sending method in some way or other." (let ((inhibit-read-only t)) (put-text-property (point-min) (point-max) 'read-only nil)) (run-hooks 'message-send-hook) - (message "Sending...") + (message-fix-before-sending) + (message message-sending-message) (let ((message-encoding-buffer (message-generate-new-buffer-clone-locals " message encoding")) (message-edit-buffer (current-buffer)) (message-mime-mode mime-edit-mode-flag) (alist message-send-method-alist) (success t) - elem sent) + elem sent + (message-options message-options)) + (message-options-set-recipient) (save-excursion (set-buffer message-encoding-buffer) (erase-buffer) (insert-buffer message-edit-buffer) (funcall message-encode-function) - (message-fix-before-sending) (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")) (prog1 @@ -2620,7 +2703,7 @@ It should typically alter the sending method in some way or other." (save-excursion (run-hooks 'message-sent-hook)) (message "Sending...done") - ;; Mark the buffer as unmodified and delete autosave. + ;; Mark the buffer as unmodified and delete auto-save. (set-buffer-modified-p nil) (delete-auto-save-file-if-necessary t) (message-disassociate-draft) @@ -2648,13 +2731,42 @@ It should typically alter the sending method in some way or other." (put 'message-check 'lisp-indent-function 1) (put 'message-check 'edebug-form-spec '(form body)) +;; This function will be used by MIME-Edit when inserting invisible parts. +(defun message-invisible-region (start end) + (if (featurep 'xemacs) + (if (save-excursion + (goto-char start) + (eq (following-char) ?\n)) + (setq start (1+ start))) + (if (save-excursion + (goto-char (1- end)) + (eq (following-char) ?\n)) + (setq end (1- end)))) + (put-text-property start end 'invisible t) + (if (eq 'message-mode major-mode) + (put-text-property start end 'message-invisible t))) + +(eval-after-load "invisible" + '(defalias 'invisible-region 'message-invisible-region)) + (defun message-fix-before-sending () "Do various things to make the message nice before sending it." ;; Make sure there's a newline at the end of the message. + (widen) (goto-char (point-max)) (unless (bolp) (insert "\n")) - ;; Delete all invisible text. + ;; Expose all invisible text with the property `message-invisible'. + ;; We should believe that the things might be created by MIME-Edit. + (let (start) + (while (setq start (text-property-any (point-min) (point-max) + 'message-invisible t)) + (remove-text-properties start + (or (text-property-not-all start (point-max) + 'message-invisible t) + (point-max)) + '(invisible nil message-invisible nil)))) + ;; Expose all invisible text. (message-check 'invisible-text (when (text-property-any (point-min) (point-max) 'invisible t) (put-text-property (point-min) (point-max) 'invisible nil) @@ -2727,6 +2839,78 @@ This sub function is for exclusive use of `message-send-mail'." (cadr failure) (prin1-to-string failure))))) +(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)) + (id (message-make-message-id)) (n 1) + plist total header required-mail-headers) + (while (not (eobp)) + (if (< (point-max) (+ p message-send-mail-partially-limit)) + (goto-char (point-max)) + (goto-char (+ p message-send-mail-partially-limit)) + (beginning-of-line) + (if (<= (point) p) (forward-line 1))) ;; In case of bad message. + (push p plist) + (setq p (point))) + (setq total (length plist)) + (push (point-max) plist) + (setq plist (nreverse plist)) + (unwind-protect + (save-excursion + (setq p (pop plist)) + (while plist + (set-buffer curbuf) + (copy-to-buffer tembuf p (car plist)) + (set-buffer tembuf) + (goto-char (point-min)) + (if header + (progn + (goto-char (point-min)) + (narrow-to-region (point) (point)) + (insert header)) + (message-goto-eoh) + (setq header (buffer-substring (point-min) (point))) + (goto-char (point-min)) + (narrow-to-region (point) (point)) + (insert header) + (message-remove-header "Mime-Version") + (message-remove-header "Content-Type") + (message-remove-header "Content-Transfer-Encoding") + (message-remove-header "Message-ID") + (message-remove-header "Lines") + (goto-char (point-max)) + (insert "Mime-Version: 1.0\n") + (setq header (buffer-substring (point-min) (point-max)))) + (goto-char (point-max)) + (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n" + id n total)) + (let ((mail-header-separator "")) + (when (memq 'Message-ID message-required-mail-headers) + (insert "Message-ID: " (message-make-message-id) "\n")) + (when (memq 'Lines message-required-mail-headers) + (let ((mail-header-separator "")) + (insert "Lines: " (message-make-lines) "\n"))) + (message-goto-subject) + (end-of-line) + (insert (format " (%d/%d)" n total)) + (goto-char (point-max)) + (insert "\n") + (widen) + (mm-with-unibyte-current-buffer + (funcall message-send-mail-function))) + (setq n (+ n 1)) + (setq p (pop plist)) + (erase-buffer))) + (kill-buffer tembuf)))) + (defun message-send-mail (&optional arg) (require 'mail-utils) (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp")) @@ -2764,9 +2948,15 @@ This sub function is for exclusive use of `message-send-mail'." ;; 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")) + (let ((ct (mime-read-Content-Type))) + (and (eq 'text (cdr (assq 'type ct))) + (eq 'plain (cdr (assq 'subtype ct))))))) (message-insert-courtesy-copy)) (setq failure (message-maybe-split-and-send-mail))) (kill-buffer tembuf)) @@ -2780,7 +2970,8 @@ 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 - (message-generate-new-buffer-clone-locals " sendmail errors") + (message-generate-new-buffer-clone-locals + " sendmail errors") 0)) resend-to-addresses delimline) (let ((case-fold-search t)) @@ -2968,6 +3159,7 @@ This sub function is for exclusive use of `message-send-news'." (method (if (message-functionp message-post-method) (funcall message-post-method arg) message-post-method)) + (group-name-charset (gnus-group-name-charset method "")) (message-syntax-checks (if arg (cons '(existing-newsgroups . disabled) @@ -2981,6 +3173,10 @@ This sub function is for exclusive use of `message-send-news'." (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 @@ -3058,7 +3254,7 @@ This sub function is for exclusive use of `message-send-news'." (defun message-check-news-header-syntax () (and ;; Check Newsgroups header. - (message-check 'newsgroyps + (message-check 'newsgroups (let ((group (message-fetch-field "newsgroups"))) (or (and group @@ -3302,11 +3498,24 @@ This sub function is for exclusive use of `message-send-news'." (message-check 'signature (goto-char (point-max)) (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)))) + (y-or-n-p + (format + "Your .sig is %d lines; it should be max 4. Really post? " + (1- (count-lines (point) (point-max))))) + 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-check-mail-syntax () "Check the syntax of the message." @@ -3413,7 +3622,7 @@ This sub function is for exclusive use of `message-send-news'." "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 () @@ -3827,7 +4036,7 @@ Headers already prepared in the buffer are not modified." ;; The element is a symbol. We insert the value ;; of this symbol, if any. (symbol-value header)) - (t + ((not (message-check-element header)) ;; We couldn't generate a value for this header, ;; so we just ask the user. (read-from-minibuffer @@ -3993,7 +4202,10 @@ than 988 characters long, and if they are not, trim them until they are." ;; 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 + ;; + ;; Only disallow folding for News messages. At this point the headers + ;; have not been generated, thus we use message-this-is-news directly. + (when (and message-this-is-news message-cater-to-broken-inn) (let ((maxsize 988) (totalsize (+ (apply #'+ (mapcar #'length refs)) (1- count))) @@ -4011,7 +4223,7 @@ than 988 characters long, and if they are not, trim them until they are." ;; 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 + (if (and message-this-is-news message-cater-to-broken-inn) (insert (capitalize (symbol-name header)) ": " refstring "\n") (message-fill-header header refstring))))) @@ -4178,6 +4390,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) @@ -4251,56 +4465,20 @@ OTHER-HEADERS is an alist of header/value pairs." (message-setup `((Newsgroups . ,(or newsgroups "")) (Subject . ,(or subject "")))))) -;;;###autoload -(defun message-reply (&optional to-address wide) - "Start editing a reply to the article in the current buffer." - (interactive) - (let ((cur (current-buffer)) - from subject date to cc - references message-id follow-to - (inhibit-point-motion-hooks t) - (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. - (if (not wide) - ;; This is a regular reply. - (if (message-functionp message-reply-to-function) - (setq follow-to (funcall message-reply-to-function))) - ;; This is a followup. - (if (message-functionp message-wide-reply-to-function) - (save-excursion - (setq follow-to - (funcall message-wide-reply-to-function))))) - ;; Find all relevant headers we need. - (setq from (message-fetch-field "from") - date (message-fetch-field "date" t) - subject (or (message-fetch-field "subject") "none") - references (message-fetch-field "references") - message-id (message-fetch-field "message-id" t) - to (message-fetch-field "to") - cc (message-fetch-field "cc") - mct (when (and wide message-use-mail-copies-to) - (message-fetch-field "mail-copies-to")) - mft (when (and wide message-use-mail-followup-to) - (message-fetch-field "mail-followup-to")) - mrt (when message-use-mail-reply-to - (or (message-fetch-field "mail-reply-to") - (message-fetch-field "reply-to"))) - 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)) - (widen)) +(defun message-get-reply-headers (wide &optional to-address) + (let (follow-to mct never-mct from to cc reply-to mrt mft) + ;; Find all relevant headers we need. + (setq from (message-fetch-field "from") + to (message-fetch-field "to") + cc (message-fetch-field "cc") + mct (when message-use-mail-copies-to + (message-fetch-field "mail-copies-to")) + reply-to (message-fetch-field "reply-to") + mrt (when message-use-mail-reply-to + (message-fetch-field "mail-reply-to")) + mft (when (and (not (or to-address mrt reply-to)) + message-use-mail-followup-to) + (message-fetch-field "mail-followup-to"))) ;; Handle special values of Mail-Copies-To. (when mct @@ -4325,7 +4503,7 @@ You should normally obey the Mail-Copies-To: header. `Mail-Copies-To: always' sends a copy of your response to the author."))) - (setq mct (or mrt from))) + (setq mct (or mrt reply-to from))) ((and (eq message-use-mail-copies-to 'ask) (not (message-y-or-n-p @@ -4336,18 +4514,13 @@ You should normally obey the Mail-Copies-To: header. sends a copy of your response to " (if (string-match "," mct) "the specified addresses" "that address") "."))) - (setq mct nil)) - )) + (setq mct nil)))) - (unless follow-to - (cond - (to-address (setq follow-to (list (cons 'To to-address)))) - ((not wide) (setq follow-to (list (cons 'To (or mrt from))))) - ;; Handle Mail-Followup-To. - ((and mft - (or (not (eq message-use-mail-followup-to 'ask)) - (message-y-or-n-p - (concat "Obey Mail-Followup-To: " mft "? ") t "\ + ;; Handle Mail-Followup-To. + (when (and mft + (eq message-use-mail-followup-to 'ask) + (not (message-y-or-n-p + (concat "Obey Mail-Followup-To: " mft "? ") t "\ You should normally obey the Mail-Followup-To: header. `Mail-Followup-To: " mft "' @@ -4360,48 +4533,122 @@ that further discussion should take place only in " (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))) - (t - (let (ccalist) - (save-excursion - (message-set-work-buffer) + (setq mft nil)) + + (if (or (not wide) + to-address) + (progn + (setq follow-to (list (cons 'To + (or to-address mrt reply-to mft from)))) + (when (and wide mct) + (push (cons 'Cc mct) follow-to))) + (let (ccalist) + (save-excursion + (message-set-work-buffer) + (if (and mft + message-use-followup-to + (or (not (eq message-use-followup-to 'ask)) + (message-y-or-n-p "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 from ""))) + (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)) - ;; Remove addresses that match `rmail-dont-reply-to-names'. - (let ((rmail-dont-reply-to-names message-dont-reply-to-names)) - (insert (prog1 (rmail-dont-reply-to (buffer-string)) - (erase-buffer)))) - (goto-char (point-min)) - ;; Perhaps Mail-Copies-To: never removed the only address? - (when (eobp) - (insert (or mrt from ""))) - (setq ccalist - (mapcar - (lambda (addr) - (cons (mail-strip-quoted-names addr) addr)) - (message-tokenize-header (buffer-string)))) - (let ((s ccalist)) - (while s - (setq ccalist (delq (assoc (car (pop s)) s) ccalist))))) - (setq follow-to (list (cons 'To (cdr (pop ccalist))))) - (when ccalist - (let ((ccs (cons 'Cc (mapconcat - (lambda (addr) (cdr addr)) ccalist ", ")))) - (when (string-match "^ +" (cdr ccs)) - (setcdr ccs (substring (cdr ccs) (match-end 0)))) - (push ccs follow-to))))))) - - (message-pop-to-buffer (message-buffer-name - (if wide "wide reply" "reply") from - (if wide to-address nil))) + (insert (if cc (concat (if (bolp) "" ", ") cc) ""))) + (goto-char (point-min)) + (while (re-search-forward "[ \t]+" nil t) + (replace-match " " t t)) + ;; Remove addresses that match `rmail-dont-reply-to-names'. + (let ((rmail-dont-reply-to-names message-dont-reply-to-names)) + (insert (prog1 (rmail-dont-reply-to (buffer-string)) + (erase-buffer)))) + (goto-char (point-min)) + ;; Perhaps "Mail-Copies-To: never" removed the only address? + (when (eobp) + (insert (or mrt reply-to from ""))) + (setq ccalist + (mapcar + (lambda (addr) + (cons (mail-strip-quoted-names addr) addr)) + (message-tokenize-header (buffer-string)))) + (let ((s ccalist)) + (while s + (setq ccalist (delq (assoc (car (pop s)) s) ccalist))))) + (setq follow-to (list (cons 'To (cdr (pop ccalist))))) + (when ccalist + (let ((ccs (cons 'Cc (mapconcat + (lambda (addr) (cdr addr)) ccalist ", ")))) + (when (string-match "^ +" (cdr ccs)) + (setcdr ccs (substring (cdr ccs) (match-end 0)))) + (push ccs follow-to))))) + follow-to)) + +;;;###autoload +(defun message-reply (&optional to-address wide) + "Start editing a reply to the article in the current buffer." + (interactive) + (require 'gnus-sum) ; for gnus-list-identifiers + (let ((cur (current-buffer)) + from subject date + references message-id follow-to + (inhibit-point-motion-hooks t) + (message-this-is-mail t) + gnus-warning in-reply-to) + (save-restriction + (message-narrow-to-head) + ;; Allow customizations to have their say. + (if (not wide) + ;; This is a regular reply. + (if (message-functionp message-reply-to-function) + (setq follow-to (funcall message-reply-to-function))) + ;; This is a followup. + (if (message-functionp message-wide-reply-to-function) + (save-excursion + (setq follow-to + (funcall message-wide-reply-to-function))))) + (setq message-id (message-fetch-field "message-id" t) + references (message-fetch-field "references") + date (message-fetch-field "date") + from (message-fetch-field "from") + subject (or (message-fetch-field "subject") "none")) + (if gnus-list-identifiers + (setq subject (message-strip-list-identifiers subject))) + (setq subject (message-make-followup-subject subject)) + + (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) + (string-match "<[^>]+>" gnus-warning)) + (setq message-id (match-string 0 gnus-warning))) + + (unless follow-to + (setq follow-to (message-get-reply-headers wide to-address))) + + ;; 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))))) + + (message-pop-to-buffer + (message-buffer-name + (if wide "wide reply" "reply") from + (if wide to-address nil))) (setq message-reply-headers (make-full-mail-header-from-decoded-header @@ -4412,7 +4659,8 @@ that further discussion should take place only in " ,@follow-to ,@(if (or references message-id) `((References . ,(concat (or references "") (and references " ") - (or message-id "")))))) + (or message-id "")))) + nil)) cur))) ;;;###autoload @@ -4426,44 +4674,44 @@ that further discussion should take place only in " "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 mct + from subject date reply-to mrt mct mft references message-id follow-to (inhibit-point-motion-hooks t) (message-this-is-news t) - followup-to distribution newsgroups gnus-warning posted-to mft mrt) + followup-to distribution newsgroups gnus-warning posted-to) (save-restriction (message-narrow-to-head) (when (message-functionp message-followup-to-function) (setq follow-to (funcall message-followup-to-function))) (setq from (message-fetch-field "from") - date (message-fetch-field "date" t) + date (message-fetch-field "date") subject (or (message-fetch-field "subject") "none") references (message-fetch-field "references") message-id (message-fetch-field "message-id" t) - followup-to (when message-use-followup-to - (message-fetch-field "followup-to")) - distribution (message-fetch-field "distribution") + followup-to (message-fetch-field "followup-to") newsgroups (message-fetch-field "newsgroups") posted-to (message-fetch-field "posted-to") + reply-to (message-fetch-field "reply-to") + mrt (when message-use-mail-reply-to + (message-fetch-field "mail-reply-to")) + distribution (message-fetch-field "distribution") mct (when message-use-mail-copies-to (message-fetch-field "mail-copies-to")) mft (when message-use-mail-followup-to - (message-fetch-field "mail-followup-to")) - mrt (when message-use-mail-reply-to - (or (message-fetch-field "mail-reply-to") - (message-fetch-field "reply-to"))) - gnus-warning (message-fetch-field "gnus-warning")) - (when (and gnus-warning (string-match "<[^>]+>" gnus-warning)) + (message-fetch-field "mail-followup-to"))) + (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) + (string-match "<[^>]+>" gnus-warning)) (setq message-id (match-string 0 gnus-warning))) ;; Remove bogus distribution. (when (and (stringp distribution) (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. + (if gnus-list-identifiers + (setq subject (message-strip-list-identifiers subject))) (setq subject (message-make-followup-subject subject)) (widen)) @@ -4489,7 +4737,7 @@ You should normally obey the Mail-Copies-To: header. `Mail-Copies-To: always' sends a copy of your response to the author."))) - (setq mct (or mrt from))) + (setq mct (or mrt reply-to from))) ((and (eq message-use-mail-copies-to 'ask) (not (message-y-or-n-p @@ -4510,7 +4758,7 @@ sends a copy of your response to " (if (string-match "," mct) (followup-to (cond ((equal (downcase followup-to) "poster") - (if (or (eq message-use-followup-to 'use) + (if (or (and followup-to (eq message-use-followup-to 'use)) (message-y-or-n-p "Obey Followup-To: poster? " t "\ You should normally obey the Followup-To: header. @@ -4521,11 +4769,11 @@ A typical situation where `Followup-To: poster' is used is when the author does not read the newsgroup, so he wouldn't see any replies sent to it.")) (setq message-this-is-news nil distribution nil - follow-to (list (cons 'To (or mrt from "")))) + follow-to (list (cons 'To (or mrt reply-to from "")))) (setq follow-to (list (cons 'Newsgroups newsgroups))))) (t (if (or (equal followup-to newsgroups) - (not (eq message-use-followup-to 'ask)) + (not (and followup-to (eq message-use-followup-to 'ask))) (message-y-or-n-p (concat "Obey Followup-To: " followup-to "? ") t "\ You should normally obey the Followup-To: header. @@ -4570,10 +4818,6 @@ that further discussion should take place only in " (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) - (setq message-reply-headers - (make-full-mail-header-from-decoded-header - 0 subject from date message-id references 0 0 "")) - (message-setup `((Subject . ,subject) ,@follow-to @@ -4582,12 +4826,17 @@ that further discussion should take place only in " ,@(if (or references message-id) `((References . ,(concat (or references "") (and references " ") (or message-id "")))))) - cur))) + cur) + + (setq message-reply-headers + (make-full-mail-header-from-decoded-header + 0 subject from date message-id references 0 0 "")))) ;;;###autoload -(defun message-cancel-news () - "Cancel an article you posted." - (interactive) +(defun message-cancel-news (&optional arg) + "Cancel an article you posted. +If ARG, allow editing of the cancellation message." + (interactive "P") (unless (message-news-p) (error "This is not a news article; canceling is impossible")) (when (yes-or-no-p "Do you really want to cancel this article? ") @@ -4613,10 +4862,12 @@ that further discussion should take place only in " (message-make-from)))))) (error "This article is not yours")) ;; Make control message. - (setq buf (set-buffer (get-buffer-create " *message cancel*"))) + (if arg + (message-news) + (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 @@ -4626,13 +4877,14 @@ that further discussion should take place only in " message-cancel-message) (run-hooks 'message-cancel-hook) (message "Canceling your article...") - (if (let ((message-syntax-checks - 'dont-check-for-anything-just-trust-me) - (message-encoding-buffer (current-buffer)) - (message-edit-buffer (current-buffer))) - (message-send-news)) - (message "Canceling your article...done")) - (kill-buffer buf))))) + (unless arg + (if (let ((message-syntax-checks + 'dont-check-for-anything-just-trust-me) + (message-encoding-buffer (current-buffer)) + (message-edit-buffer (current-buffer))) + (message-send-news)) + (message "Canceling your article...done")) + (kill-buffer buf)))))) (defun message-supersede-setup-for-mime-edit () (set (make-local-variable 'message-setup-hook) nil) @@ -4685,6 +4937,8 @@ header line with the old Message-ID." (cond ((save-window-excursion (if (not (eq system-type 'vax-vms)) (with-output-to-temp-buffer "*Directory*" + (with-current-buffer standard-output + (fundamental-mode)) ; for Emacs 20.4+ (buffer-disable-undo standard-output) (let ((default-directory "/")) (call-process @@ -4750,7 +5004,6 @@ the message." "Return a Subject header suitable for the message in the current buffer." (save-excursion (save-restriction - (current-buffer) (message-narrow-to-head) (let ((funcs message-make-forward-subject-function) (subject (message-fetch-field "Subject"))) @@ -4786,11 +5039,11 @@ Optional NEWS will use news to forward instead of mail." (message-mail nil subject)) ;; Put point where we want it before inserting the forwarded ;; message. - (if message-signature-before-forwarded-message - (goto-char (point-max)) - (message-goto-body)) + (if message-forward-before-signature + (message-goto-body) + (goto-char (point-max))) ;; Make sure we're at the start of the line. - (unless (eolp) + (unless (bolp) (insert "\n")) ;; Narrow to the area we are to insert. (narrow-to-region (point) (point)) @@ -4871,7 +5124,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) @@ -5007,7 +5260,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. @@ -5080,6 +5333,7 @@ The following arguments may contain lists of values." (save-excursion (with-output-to-temp-buffer " *MESSAGE information message*" (set-buffer " *MESSAGE information message*") + (fundamental-mode) ; for Emacs 20.4+ (mapcar 'princ text) (goto-char (point-min)))) (funcall ask question)) @@ -5171,17 +5425,20 @@ 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)) +(static-if (fboundp 'subst-char-in-string) + (defsubst message-replace-chars-in-string (string from to) + (subst-char-in-string from to string)) + (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))) ;;; ;;; MIME functions @@ -5237,27 +5494,64 @@ 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"))))) -(defvar message-save-buffer " *encoding") (defun message-save-drafts () + "Postponing the message." (interactive) - (if (not (get-buffer message-save-buffer)) - (get-buffer-create message-save-buffer)) - (let ((filename buffer-file-name) - (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) - (set-buffer-modified-p nil))) + (message "Saving %s..." buffer-file-name) + (let ((reply-headers message-reply-headers) + (msg (buffer-substring-no-properties (point-min) (point-max)))) + (with-temp-file buffer-file-name + (insert msg) + (setq message-reply-headers reply-headers) + (message-generate-headers '((optional . In-Reply-To))) + (mime-edit-translate-buffer)) + (set-buffer-modified-p nil)) + (message "Saving %s...done" buffer-file-name)) (provide 'message)