X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=38073b401653fca5a678f6c7037a7885883f76f9;hb=1182f5cade98dfd7b3f8fb11850f7525e065d167;hp=21b92297c197a37515d9b7f786bb0db310ebe490;hpb=1543e06c1d81a83ac38146e6ae65ab3264c2ae2f;p=gnus diff --git a/lisp/message.el b/lisp/message.el index 21b92297c..38073b401 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -1,7 +1,8 @@ ;;; message.el --- composing mail and news messages -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2000 +;; Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen +;; Author: Lars Magne Ingebrigtsen ;; Keywords: mail, news ;; This file is part of GNU Emacs. @@ -29,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 'timezone) -(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 'mail-parse) +(require 'mml) (defgroup message '((user-mail-address custom-variable) (user-full-name custom-variable)) @@ -157,26 +158,28 @@ Otherwise, most addresses look like `angles', but they look like (defcustom message-syntax-checks nil ;; Guess this one shouldn't be easy to customize... - "Controls what syntax checks should not be performed on outgoing posts. + "*Controls what syntax checks should not be performed on outgoing posts. To disable checking of long signatures, for instance, add `(signature . disabled)' to this list. 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." - :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 (optional . Organization) Lines - (optional . X-Newsreader)) - "Headers to be generated or prompted for when posting an article. + (optional . User-Agent)) + "*Headers to be generated or prompted for when posting an article. RFC977 and RFC1036 require From, Date, Newsgroups, Subject, Message-ID. Organization, Lines, In-Reply-To, Expires, and -X-Newsreader are optional. If don't you want message to insert some +User-Agent are optional. If don't you want message to insert some header, remove it from this list." :group 'message-news :group 'message-headers @@ -184,10 +187,10 @@ header, remove it from this list." (defcustom message-required-mail-headers '(From Subject Date (optional . In-Reply-To) Message-ID Lines - (optional . X-Mailer)) - "Headers to be generated or prompted for when mailing a message. + (optional . User-Agent)) + "*Headers to be generated or prompted for when mailing a message. RFC822 required that From, Date, To, Subject and Message-ID be -included. Organization, Lines and X-Mailer are optional." +included. Organization, Lines and User-Agent are optional." :group 'message-mail :group 'message-headers :type '(repeat sexp)) @@ -210,21 +213,28 @@ included. Organization, Lines and X-Mailer 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." :group 'message-interface :type 'regexp) +(defcustom message-subject-re-regexp "^[ \t]*\\([Rr][Ee]:[ \t]*\\)*[ \t]*" + "*Regexp matching \"Re: \" in the subject line." + :group 'message-various + :type 'regexp) + ;;;###autoload (defcustom message-signature-separator "^-- *$" "Regexp matching the signature separator." :type 'regexp :group 'message-various) -(defcustom message-elide-elipsis "\n[...]\n\n" - "*The string which is inserted for elided text.") +(defcustom message-elide-ellipsis "\n[...]\n\n" + "*The string which is inserted for elided text." + :type 'string + :group 'message-various) (defcustom message-interactive nil "Non-nil means when sending a message wait for and display errors. @@ -233,14 +243,15 @@ nil means let mailer mail back a message to report errors." :group 'message-mail :type 'boolean) -(defcustom message-generate-new-buffers t - "*Non-nil means that a new message buffer will be created whenever `mail-setup' is called. +(defcustom message-generate-new-buffers 'unique + "*Non-nil means that a new message buffer will be created whenever `message-setup' is called. If this is a function, call that function with three parameters: The type, the to address and the group name. (Any of these may be nil.) The function should return the new buffer name." :group 'message-buffers :type '(choice (const :tag "off" nil) - (const :tag "on" t) + (const :tag "unique" unique) + (const :tag "unsent" unsent) (function fun))) (defcustom message-kill-buffer-on-exit nil @@ -267,47 +278,59 @@ If t, use `message-user-organization-file'." :type 'file :group 'message-headers) -(defcustom message-autosave-directory - (nnheader-concat message-directory "drafts/") - "*Directory where Message autosaves buffers. -If nil, Message won't autosave." - :group 'message-buffers - :type 'directory) +(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 +successive function. + +The provided functions are: -(defcustom message-forward-start-separator - "------- Start of forwarded message -------\n" - "*Delimiter inserted before forwarded messages." +* message-forward-subject-author-subject (Source of article (author or + newsgroup)), in brackets followed by the subject +* message-forward-subject-fwd (Subject of article with 'Fwd:' prepended + to it." :group 'message-forwarding - :type 'string) + :type '(radio (function-item message-forward-subject-author-subject) + (function-item message-forward-subject-fwd))) -(defcustom message-forward-end-separator - "------- End of forwarded message -------\n" - "*Delimiter inserted after forwarded messages." +(defcustom message-forward-as-mime t + "*If non-nil, forward messages as an inline/rfc822 MIME section. Otherwise, directly inline the old message in the forwarded message." :group 'message-forwarding - :type 'string) + :type 'boolean) -(defcustom message-signature-before-forwarded-message t - "*If non-nil, put the signature before any included forwarded message." +(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-included-forward-headers - "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-Transfer-Encoding:\\|^Content-Type:\\|^Mime-Version:" - "*Regexp matching headers to be included in forwarded messages." +(defcustom message-forward-before-signature t + "*If non-nil, put forwarded message before signature, else after." :group 'message-forwarding - :type 'regexp) + :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 + :type 'boolean) -(defcustom message-ignored-resent-headers "^Return-receipt" +(defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:" "*All headers that match this regexp will be deleted when resending a message." :group 'message-interface :type 'regexp) +(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) + regexp)) + (defcustom message-ignored-cited-headers "." "*Delete these headers from the messages you yank." :group 'message-insertion :type 'regexp) -(defcustom message-cancel-message "I am canceling my own article." +(defcustom message-cancel-message "I am canceling my own article.\n" "Message to be inserted in the cancel message." :group 'message-interface :type 'string) @@ -319,7 +342,7 @@ If nil, Message won't autosave." 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 `smtpmail-send-it'." :type '(radio (function-item message-send-mail-with-sendmail) @@ -370,10 +393,9 @@ always query the user whether to use the value. If it is the symbol (const use) (const ask))) -;; stuff relating to broken sendmail in MMDF (defcustom message-sendmail-f-is-evil nil - "*Non-nil means that \"-f username\" should not be added to the sendmail -command line, because it is even more evil than leaving it out." + "*Non-nil means that \"-f username\" should not be added to the sendmail command line. +Doing so would be even more evil than leaving it out." :group 'message-sending :type 'boolean) @@ -393,16 +415,24 @@ might set this variable to '(\"-f\" \"you@some.where\")." :group 'message-sending :type '(repeat string)) +(defvar message-cater-to-broken-inn t + "Non-nil means Gnus should not fold the `References' header. +Folding `References' makes ancient versions of INN create incorrect +NOV lines.") + (defvar gnus-post-method) (defvar gnus-select-method) (defcustom message-post-method (cond ((and (boundp 'gnus-post-method) + (listp gnus-post-method) gnus-post-method) gnus-post-method) ((boundp 'gnus-select-method) gnus-select-method) (t '(nnspool ""))) - "Method used to post news." + "*Method used to post news. +Note that when posting from inside Gnus, for instance, this +variable isn't used." :group 'message-news :group 'message-sending ;; This should be the `gnus-select-method' widget, but that might @@ -420,6 +450,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 @@ -438,8 +473,7 @@ the signature is inserted." :type 'hook) (defcustom message-header-setup-hook nil - "Hook called narrowed to the headers when setting up a message -buffer." + "Hook called narrowed to the headers when setting up a message buffer." :group 'message-various :type 'hook) @@ -451,8 +485,7 @@ buffer." ;;;###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) @@ -463,14 +496,11 @@ Used by `message-yank-original' via `message-yank-cite'." :type 'integer) ;;;###autoload -(defcustom message-cite-function - (if (and (boundp 'mail-citation-hook) - mail-citation-hook) - mail-citation-hook - 'message-cite-original) +(defcustom message-cite-function 'message-cite-original "*Function for citing an original message. -Pre-defined functions include `message-cite-original' and -`message-cite-original-without-signature'." +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) @@ -543,6 +573,7 @@ If stringp, use this; if non-nil, use no host name (user name only)." (define-widget 'message-header-lines 'text "All header lines must be LFD terminated." + :format "%t:%n%v" :valid-regexp "^\\'" :error "All header lines must be newline terminated") @@ -560,8 +591,7 @@ these lines." :type 'message-header-lines) (defcustom message-default-news-headers "" - "*A string of header lines to be inserted in outgoing news -articles." + "*A string of header lines to be inserted in outgoing news articles." :group 'message-headers :group 'message-news :type 'message-header-lines) @@ -586,21 +616,17 @@ articles." ;; 33 and 126, except colon)", i. e., any chars except ctl chars, ;; space, or colon. '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:")) - "Set this non-nil if the system's mailer runs the header and body together. + "*Set this non-nil if the system's mailer runs the header and body together. \(This problem exists on Sunos 4 when sendmail is run in remote mode.) The value should be an expression to test whether the problem will 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 -(condition-case nil - (define-mail-user-agent 'message-user-agent - 'message-mail 'message-send-and-exit - 'message-kill-buffer 'message-send-hook) - (error nil)) +(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.") @@ -624,12 +650,43 @@ the prefix.") The default is `abbrev', which uses mailabbrev. nil switches mail aliases off.") +(defcustom message-auto-save-directory + (nnheader-concat message-directory "drafts/") + "*Directory where Message auto-saves buffers if Gnus isn't running. +If nil, Message won't auto-save." + :group 'message-buffers + :type 'directory) + +(defcustom message-buffer-naming-style 'unique + "*The way new message buffers are named. +Valid valued are `unique' and `unsent'." + :group 'message-buffers + :type '(choice (const :tag "unique" unique) + (const :tag "unsent" unsent))) + +(defcustom message-default-charset + (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 + (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 + :type '(choice (const :tag "Yourself" nil) + regexp)) + ;;; Internal variables. ;;; Well, not really internal. (defvar message-mode-syntax-table (let ((table (copy-syntax-table text-mode-syntax-table))) (modify-syntax-entry ?% ". " table) + (modify-syntax-entry ?> ". " table) + (modify-syntax-entry ?< ". " table) table) "Syntax table used while in Message mode.") @@ -749,6 +806,18 @@ Defaults to `text-mode-abbrev-table'.") "Face used for displaying cited text names." :group 'message-faces) +(defface message-mml-face + '((((class color) + (background dark)) + (:foreground "ForestGreen")) + (((class color) + (background light)) + (:foreground "ForestGreen")) + (t + (:bold t))) + "Face used for displaying MML." + :group 'message-faces) + (defvar message-font-lock-keywords (let* ((cite-prefix "A-Za-z") (cite-suffix (concat cite-prefix "0-9_.@-")) @@ -771,12 +840,17 @@ Defaults to `text-mode-abbrev-table'.") (,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content) (1 'message-header-name-face) (2 'message-header-name-face)) - (,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") - 1 'message-separator-face) + ,@(if (and mail-header-separator + (not (equal mail-header-separator ""))) + `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") + 1 'message-separator-face)) + nil) (,(concat "^[ \t]*" "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" "[:>|}].*") - (0 'message-cited-text-face)))) + (0 'message-cited-text-face)) + ("<#/?\\(multipart\\|part\\|external\\|mml\\).*>" + (0 'message-mml-face)))) "Additional expressions to highlight in Message mode.") ;; XEmacs does it like this. For Emacs, we have to set the @@ -813,12 +887,37 @@ The cdr of ech entry is a function for applying the face to a region.") :group 'message-various :type 'hook) +(defvar message-send-coding-system 'binary + "Coding system to encode outgoing mail.") + +(defvar message-draft-coding-system + mm-auto-save-coding-system + "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) (defvar message-draft-article nil) +(defvar message-mime-part nil) +(defvar message-posting-charset nil) ;; Byte-compiler warning (defvar gnus-active-hashtb) @@ -858,10 +957,10 @@ The cdr of ech entry is a function for applying the face to a region.") "\\([^\0-\b\n-\r\^?].*\\)? " ;; The time the message was sent. - "\\([^\0-\r \^?]+\\) +" ; day of the week - "\\([^\0-\r \^?]+\\) +" ; month - "\\([0-3]?[0-9]\\) +" ; day of month - "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day + "\\([^\0-\r \^?]+\\) +" ; day of the week + "\\([^\0-\r \^?]+\\) +" ; month + "\\([0-3]?[0-9]\\) +" ; day of month + "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day ;; Perhaps a time zone, specified by an abbreviation, or by a ;; numeric offset. @@ -886,6 +985,7 @@ The cdr of ech entry is a function for applying the face to a region.") "^ *---+ +Original message +---+ *$\\|" "^ *--+ +begin message +--+ *$\\|" "^ *---+ +Original message follows +---+ *$\\|" + "^ *---+ +Undelivered message follows +---+ *$\\|" "^|? *---+ +Message text follows: +---+ *|?$") "A regexp that matches the separator before the text of a failed message.") @@ -903,9 +1003,8 @@ The cdr of ech entry is a function for applying the face to a region.") (Lines) (Expires) (Message-ID) - (References . message-fill-header) - (X-Mailer) - (X-Newsreader)) + (References . message-shorten-references) + (User-Agent)) "Alist used for formatting headers.") (eval-and-compile @@ -914,11 +1013,16 @@ The cdr of ech entry is a function for applying the face to a region.") (autoload 'mh-send-letter "mh-comp") (autoload 'gnus-point-at-eol "gnus-util") (autoload 'gnus-point-at-bol "gnus-util") - (autoload 'gnus-output-to-mail "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") - (autoload 'nndraft-request-expire-articles "nndraft")) + (autoload 'nndraft-request-expire-articles "nndraft") + (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")) @@ -935,9 +1039,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 ","))) @@ -959,31 +1073,50 @@ The cdr of ech entry is a function for applying the face to a region.") (not paren)))) (push (buffer-substring beg (point)) elems) (setq beg (match-end 0))) - ((= (following-char) ?\") + ((eq (char-after) ?\") (setq quoted (not quoted))) - ((and (= (following-char) ?\() + ((and (eq (char-after) ?\() (not quoted)) (setq paren t)) - ((and (= (following-char) ?\)) + ((and (eq (char-after) ?\)) (not quoted)) (setq paren nil)))) - (nreverse elems))))) + (nreverse elems))))) (defun message-mail-file-mbox-p (file) "Say whether FILE looks like a Unix mbox file." (when (and (file-exists-p file) (file-readable-p file) (file-regular-p file)) - (nnheader-temp-write nil + (with-temp-buffer (nnheader-insert-file-contents file) (goto-char (point-min)) (looking-at message-unix-mail-delimiter)))) (defun message-fetch-field (header &optional not-all) "The same as `mail-fetch-field', only remove all newlines." - (let ((value (mail-fetch-field header nil (not not-all)))) + (let* ((inhibit-point-motion-hooks t) + (case-fold-search t) + (value (mail-fetch-field header nil (not not-all)))) (when value - (nnheader-replace-chars-in-string value ?\n ? )))) + (while (string-match "\n[\t ]+" value) + (setq value (replace-match " " t t 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." + (beginning-of-line) + (narrow-to-region + (point) + (progn + (forward-line 1) + (if (re-search-forward "^[^ \n\t]" nil t) + (progn + (beginning-of-line) + (point)) + (point-max)))) + (goto-char (point-min))) (defun message-add-header (&rest headers) "Add the HEADERS to the message header, skipping those already present." @@ -992,12 +1125,13 @@ The cdr of ech entry is a function for applying the face to a region.") (unless (string-match "^\\([^:]+\\):[ \t]*[^ \t]" (car headers)) (error "Invalid header `%s'" (car headers))) (setq hclean (match-string 1 (car headers))) - (save-restriction - (message-narrow-to-headers) - (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t) - (insert (car headers) ?\n)))) + (save-restriction + (message-narrow-to-headers) + (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t) + (insert (car headers) ?\n)))) (setq headers (cdr headers)))) + (defun message-fetch-reply-field (header) "Fetch FIELD from the message we're replying to." (when (and message-reply-buffer @@ -1013,7 +1147,7 @@ The cdr of ech entry is a function for applying the face to a region.") (erase-buffer)) (set-buffer (get-buffer-create " *message work*")) (kill-all-local-variables) - (buffer-disable-undo (current-buffer)))) + (mm-enable-multibyte))) (defun message-functionp (form) "Return non-nil if FORM is funcallable." @@ -1021,9 +1155,24 @@ 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 "^[Rr][Ee]: *" subject) + (if (string-match message-subject-re-regexp subject) (substring subject (match-end 0)) subject)) @@ -1033,7 +1182,7 @@ If REGEXP, HEADER is a regular expression. If FIRST, only remove the first instance of the header. Return the number of headers removed." (goto-char (point-min)) - (let ((regexp (if is-regexp header (concat "^" header ":"))) + (let ((regexp (if is-regexp header (concat "^" (regexp-quote header) ":"))) (number 0) (case-fold-search t) last) @@ -1058,9 +1207,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) @@ -1073,7 +1234,8 @@ Return the number of headers removed." (goto-char (point-min))) (defun message-narrow-to-head () - "Narrow the buffer to the head of the message." + "Narrow the buffer to the head of the message. +Point is left at the beginning of the narrowed-to region." (widen) (narrow-to-region (goto-char (point-min)) @@ -1082,24 +1244,41 @@ Return the number of headers removed." (point-max))) (goto-char (point-min))) +(defun message-narrow-to-headers-or-head () + "Narrow the buffer to the head of the message." + (widen) + (narrow-to-region + (goto-char (point-min)) + (cond + ((re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n") nil t) + (match-beginning 0)) + ((search-forward "\n\n" nil t) + (1- (point))) + (t + (point-max)))) + (goto-char (point-min))) + (defun message-news-p () "Say whether the current buffer contains a news message." - (or message-this-is-news - (save-excursion - (save-restriction - (message-narrow-to-headers) - (and (message-fetch-field "newsgroups") - (not (message-fetch-field "posted-to"))))))) + (and (not message-this-is-mail) + (or message-this-is-news + (save-excursion + (save-restriction + (message-narrow-to-headers) + (and (message-fetch-field "newsgroups") + (not (message-fetch-field "posted-to")))))))) (defun message-mail-p () "Say whether the current buffer contains a mail message." - (or message-this-is-mail - (save-excursion - (save-restriction - (message-narrow-to-headers) - (or (message-fetch-field "to") - (message-fetch-field "cc") - (message-fetch-field "bcc")))))) + (and (not message-this-is-news) + (or message-this-is-mail + (save-excursion + (save-restriction + (message-narrow-to-headers) + (or (message-fetch-field "to") + (message-fetch-field "cc") + (message-fetch-field "bcc"))))))) (defun message-next-header () "Go to the beginning of the next header." @@ -1112,6 +1291,7 @@ Return the number of headers removed." (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 () @@ -1154,7 +1334,8 @@ Return the number of headers removed." (defvar message-mode-map nil) (unless message-mode-map - (setq message-mode-map (copy-keymap text-mode-map)) + (setq message-mode-map (make-keymap)) + (set-keymap-parent message-mode-map text-mode-map) (define-key message-mode-map "\C-c?" 'describe-mode) (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to) @@ -1175,8 +1356,10 @@ Return the number of headers removed." (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups) (define-key message-mode-map "\C-c\C-y" 'message-yank-original) + (define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer) (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message) (define-key message-mode-map "\C-c\C-w" 'message-insert-signature) + (define-key message-mode-map "\C-c\M-h" 'message-insert-headers) (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) @@ -1191,6 +1374,8 @@ Return the number of headers removed." (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature) (define-key message-mode-map "\M-\r" 'message-newline-and-reformat) + (define-key message-mode-map "\C-c\C-a" 'mml-attach-file) + (define-key message-mode-map "\t" 'message-tab)) (easy-menu-define @@ -1208,9 +1393,11 @@ Return the number of headers removed." ["Newline and Reformat" message-newline-and-reformat t] ["Rename buffer" message-rename-buffer t] ["Spellcheck" ispell-message t] + ["Attach file as MIME" mml-attach-file t] "----" ["Send Message" message-send-and-exit t] - ["Abort Message" message-dont-send t])) + ["Abort Message" message-dont-send t] + ["Kill Message" message-kill-buffer t])) (easy-menu-define message-mode-field-menu message-mode-map "" @@ -1238,6 +1425,7 @@ Return the number of headers removed." "Major mode for editing mail and news to be sent. Like Text Mode but with these additional commands: C-c C-s message-send (send the message) C-c C-c message-send-and-exit +C-c C-d Pospone sending the message C-c C-k Kill the message C-c C-f move to a header field (and create it if there isn't): C-c C-f C-t move to To C-c C-f C-s move to Subject C-c C-f C-c move to Cc C-c C-f C-b move to Bcc @@ -1253,13 +1441,18 @@ C-c C-w message-insert-signature (insert `message-signature-file' file). C-c C-y message-yank-original (insert current message, if any). C-c C-q message-fill-yanked-message (fill what was yanked). C-c C-e message-elide-region (elide the text between point and mark). -C-c C-r message-caesar-buffer-body (rot13 the message body)." +C-c C-v message-delete-not-region (remove the text outside the region). +C-c C-z message-kill-to-signature (kill the text up to the signature). +C-c C-r message-caesar-buffer-body (rot13 the message body). +C-c C-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) - (make-local-variable 'message-reply-buffer) - (setq message-reply-buffer nil) - (make-local-variable 'message-send-actions) - (make-local-variable 'message-exit-actions) + (set (make-local-variable 'message-reply-buffer) nil) + (make-local-variable 'message-send-actions) + (make-local-variable 'message-exit-actions) (make-local-variable 'message-kill-actions) (make-local-variable 'message-postpone-actions) (make-local-variable 'message-draft-article) @@ -1280,46 +1473,67 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (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) - (setq paragraph-start - (concat (regexp-quote mail-header-separator) - "$\\|[ \t]*[-_][-_][-_]+$\\|" - "-- $\\|" - ;;!!! Uhm... shurely this can't be right. - "[> " (regexp-quote message-yank-prefix) "]+$\\|" - paragraph-start)) - (setq paragraph-separate - (concat (regexp-quote mail-header-separator) - "$\\|[ \t]*[-_][-_][-_]+$\\|" - "-- $\\|" - "[> " (regexp-quote message-yank-prefix) "]+$\\|" - paragraph-separate)) (make-local-variable 'message-reply-headers) (setq message-reply-headers nil) (make-local-variable 'message-newsreader) (make-local-variable 'message-mailer) (make-local-variable 'message-post-method) - (make-local-variable 'message-sent-message-via) - (setq message-sent-message-via nil) - (make-local-variable 'message-checksum) - (setq message-checksum nil) + (set (make-local-variable 'message-sent-message-via) nil) + (set (make-local-variable 'message-checksum) nil) + (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. (when (eq message-mail-alias-type 'abbrev) (if (fboundp 'mail-abbrevs-setup) (mail-abbrevs-setup) - (funcall (intern "mail-aliases-setup")))) + (mail-aliases-setup))) (message-set-auto-save-file-name) - (run-hooks 'text-mode-hook 'message-mode-hook) - (unless (string-match "XEmacs" emacs-version) - (set (make-local-variable 'font-lock-defaults) - '(message-font-lock-keywords 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]+:"))) @@ -1389,15 +1603,25 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (interactive) (if (looking-at "[ \t]*\n") (expand-abbrev)) (goto-char (point-min)) - (search-forward (concat "\n" mail-header-separator "\n") nil t)) + (or (search-forward (concat "\n" mail-header-separator "\n") nil t) + (search-forward "\n\n" nil t))) + +(defun message-goto-eoh () + "Move point to the end of the headers." + (interactive) + (message-goto-body) + (forward-line -1)) (defun message-goto-signature () - "Move point to the beginning of the message signature." + "Move point to the beginning of the message signature. +If there is no signature in the article, go to the end and +return nil." (interactive) (goto-char (point-min)) (if (re-search-forward message-signature-separator nil t) (forward-line 1) - (goto-char (point-max)))) + (goto-char (point-max)) + nil)) @@ -1410,7 +1634,8 @@ With the prefix argument FORCE, insert the header anyway." (let ((co (message-fetch-reply-field "mail-copies-to"))) (when (and (null force) co - (equal (downcase co) "never")) + (or (equal (downcase co) "never") + (equal (downcase co) "nobody"))) (error "The user has requested not to have copies sent via mail"))) (when (and (message-position-on-field "To") (mail-fetch-field "to") @@ -1419,6 +1644,24 @@ With the prefix argument FORCE, insert the header anyway." (insert (or (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) @@ -1437,23 +1680,25 @@ With the prefix argument FORCE, insert the header anyway." (interactive "r") (save-excursion (goto-char end) - (delete-region (point) (progn (message-goto-signature) - (forward-line -2) - (point))) + (delete-region (point) (if (not (message-goto-signature)) + (point) + (forward-line -2) + (point))) (insert "\n") (goto-char beg) (delete-region beg (progn (message-goto-body) (forward-line 2) (point)))) - (message-goto-signature) - (forward-line -2)) + (when (message-goto-signature) + (forward-line -2))) (defun message-kill-to-signature () "Deletes all text up to the signature." (interactive) (let ((point (point))) (message-goto-signature) - (forward-line -2) + (unless (eobp) + (forward-line -2)) (kill-region point (point)) (unless (bolp) (insert "\n")))) @@ -1461,17 +1706,24 @@ With the prefix argument FORCE, insert the header anyway." (defun message-newline-and-reformat () "Insert four newlines, and then reformat if inside quoted text." (interactive) - (let ((point (point)) - quoted) - (save-excursion - (beginning-of-line) - (setq quoted (looking-at (regexp-quote message-yank-prefix)))) - (insert "\n\n\n\n") + (let ((prefix "[]>ยป|:}+ \t]*") + (supercite-thing "[-._a-zA-Z0-9]*[>]+[ \t]*") + quoted point) + (unless (bolp) + (save-excursion + (beginning-of-line) + (when (looking-at (concat prefix + supercite-thing)) + (setq quoted (match-string 0)))) + (insert "\n")) + (setq point (point)) + (insert "\n\n\n") + (delete-region (point) (re-search-forward "[ \t]*")) (when quoted - (insert message-yank-prefix)) + (insert quoted)) (fill-paragraph nil) (goto-char point) - (forward-line 2))) + (forward-line 1))) (defun message-insert-signature (&optional force) "Insert a signature. See documentation for the `message-signature' variable." @@ -1482,8 +1734,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) @@ -1512,13 +1763,12 @@ With the prefix argument FORCE, insert the header anyway." (or (bolp) (insert "\n"))))) (defun message-elide-region (b e) - "Elide the text between point and mark. An ellipsis (from -message-elide-elipsis) will be inserted where the text was killed." + "Elide the text between point and mark. +An ellipsis (from `message-elide-ellipsis') will be inserted where the +text was killed." (interactive "r") (kill-region b e) - (unless (bolp) - (insert "\n")) - (insert message-elide-elipsis)) + (insert message-elide-ellipsis)) (defvar message-caesar-translation-table nil) @@ -1537,15 +1787,9 @@ message-elide-elipsis) will be inserted where the text was killed." ;; We build the table, if necessary. (when (or (not message-caesar-translation-table) (/= (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) - (subst-char-in-region - b (1+ b) (char-after b) - (aref message-caesar-translation-table (char-after b))) - (incf b)))) + (setq message-caesar-translation-table + (message-make-caesar-translation-table n))) + (translate-region b e message-caesar-translation-table))) (defun message-make-caesar-translation-table (n) "Create a rot table with offset N." @@ -1582,11 +1826,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\". @@ -1609,11 +1850,7 @@ name, rather than giving an automatic name." (name-default (concat "*message* " mail-trimmed-to)) (name (if enter-string (read-string "New buffer name: " name-default) - name-default)) - (default-directory - (if message-autosave-directory - (file-name-as-directory message-autosave-directory) - default-directory))) + name-default))) (rename-buffer name t))))) (defun message-fill-yanked-message (&optional justifyp) @@ -1624,7 +1861,7 @@ Numeric argument means justify as well." (goto-char (point-min)) (search-forward (concat "\n" mail-header-separator "\n") nil t) (let ((fill-prefix message-yank-prefix)) - (fill-individual-paragraphs (point) (point-max) justifyp t)))) + (fill-individual-paragraphs (point) (point-max) justifyp)))) (defun message-indent-citation () "Modify text just inserted from a message to be cited. @@ -1693,7 +1930,25 @@ prefix, and don't delete any headers." (unless (bolp) (insert ?\n)) (unless modified - (setq message-checksum (cons (message-checksum) (buffer-size))))))) + (setq message-checksum (message-checksum)))))) + +(defun message-yank-buffer (buffer) + "Insert BUFFER into the current buffer and quote it." + (interactive "bYank buffer: ") + (let ((message-reply-buffer buffer)) + (save-window-excursion + (message-yank-original)))) + +(defun message-buffers () + "Return a list of active message buffers." + (let (buffers) + (save-excursion + (dolist (buffer (buffer-list t)) + (set-buffer buffer) + (when (and (eq major-mode 'message-mode) + (null message-sent-message-via)) + (push (buffer-name buffer) buffers)))) + (nreverse buffers))) (defun message-cite-original-without-signature () "Cite function in the standard Message manner." @@ -1704,8 +1959,16 @@ prefix, and don't delete any headers." (if (listp message-indent-citation-function) message-indent-citation-function (list message-indent-citation-function))))) + (mml-quote-region start end) + ;; Allow undoing. + (undo-boundary) (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]*$") + (forward-line -1)) + (forward-line 1) (delete-region (point) end)) (goto-char start) (while functions @@ -1715,21 +1978,27 @@ prefix, and don't delete any headers." (insert "\n")) (funcall message-citation-line-function)))) +(defvar mail-citation-hook) ;Compiler directive (defun message-cite-original () "Cite function in the standard Message manner." - (let ((start (point)) - (functions - (when message-indent-citation-function - (if (listp message-indent-citation-function) - message-indent-citation-function - (list message-indent-citation-function))))) - (goto-char start) - (while functions - (funcall (pop functions))) - (when message-citation-line-function - (unless (bolp) - (insert "\n")) - (funcall message-citation-line-function)))) + (if (and (boundp 'mail-citation-hook) + mail-citation-hook) + (run-hooks 'mail-citation-hook) + (let ((start (point)) + (end (mark t)) + (functions + (when message-indent-citation-function + (if (listp message-indent-citation-function) + message-indent-citation-function + (list message-indent-citation-function))))) + (mml-quote-region start end) + (goto-char start) + (while functions + (funcall (pop functions))) + (when message-citation-line-function + (unless (bolp) + (insert "\n")) + (funcall message-citation-line-function))))) (defun message-insert-citation-line () "Function that inserts a simple citation line." @@ -1804,11 +2073,13 @@ The text will also be indented the normal way." (bury-buffer buf) (when (eq buf (current-buffer)) (message-bury buf))) - (message-do-actions actions)))) + (message-do-actions actions) + t))) (defun message-dont-send () "Don't send the message you have been editing." (interactive) + (set-buffer-modified-p t) (save-buffer) (let ((actions message-postpone-actions)) (message-bury (current-buffer)) @@ -1836,66 +2107,81 @@ The text will also be indented the normal way." (defun message-send (&optional arg) "Send the message in the current buffer. -If `message-interactive' is non-nil, wait for success indication -or error messages, and inform user. -Otherwise any failure is reported in a message back to -the user from the mailer." +If `message-interactive' is non-nil, wait for success indication or +error messages, and inform user. +Otherwise any failure is reported in a message back to the user from +the mailer. +The usage of ARG is defined by the instance that called Message. +It should typically alter the sending method in some way or other." (interactive "P") - ;; Disabled test. - (when (or (buffer-modified-p) - (message-check-element 'unchanged) - (y-or-n-p "No changes in the buffer; really send? ")) - ;; Make it possible to undo the coming changes. - (undo-boundary) - (let ((inhibit-read-only t)) - (put-text-property (point-min) (point-max) 'read-only nil)) - (message-fix-before-sending) - (run-hooks 'message-send-hook) - (message "Sending...") - (let ((alist message-send-method-alist) - (success t) - elem sent) - (while (and success - (setq elem (pop alist))) - (when (and (or (not (funcall (cadr elem))) - (and (or (not (memq (car elem) - message-sent-message-via)) - (y-or-n-p - (format - "Already sent message via %s; resend? " - (car elem)))) - (setq success (funcall (caddr elem) arg))))) - (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)))) + ;; Make it possible to undo the coming changes. + (undo-boundary) + (let ((inhibit-read-only t)) + (put-text-property (point-min) (point-max) 'read-only nil)) + (message-fix-before-sending) + (run-hooks 'message-send-hook) + (message message-sending-message) + (let ((alist message-send-method-alist) + (success t) + elem sent) + (while (and success + (setq elem (pop alist))) + (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) + (message-do-fcc) + (save-excursion + (run-hooks 'message-sent-hook)) + (message "Sending...done") + ;; Mark the buffer as unmodified and delete auto-save. + (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))) (defun message-send-via-mail (arg) - "Send the current message via mail." + "Send the current message via mail." (message-send-mail arg)) (defun message-send-via-news (arg) "Send the current message via news." (funcall message-send-news-function arg)) +(defmacro message-check (type &rest forms) + "Eval FORMS if TYPE is to be checked." + `(or (message-check-element ,type) + (save-excursion + ,@forms))) + +(put 'message-check 'lisp-indent-function 1) +(put 'message-check 'edebug-form-spec '(form body)) + (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. (goto-char (point-max)) (unless (bolp) - (insert "\n"))) + (insert "\n")) + ;; Delete 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) + (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) "Add ACTION to be performed when doing an exit of type TYPES." @@ -1918,12 +2204,83 @@ the user from the mailer." (eval (car actions))))) (pop actions))) +(defun message-send-mail-partially () + "Sendmail as message/partial." + (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")) - (case-fold-search nil) - (news (message-news-p)) - (mailbuf (current-buffer))) + (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp")) + (case-fold-search nil) + (news (message-news-p)) + (mailbuf (current-buffer)) + (message-this-is-mail t) + (message-posting-charset + (if (fboundp 'gnus-setup-posting-charset) + (gnus-setup-posting-charset nil) + message-posting-charset))) (save-restriction (message-narrow-to-headers) ;; Insert some headers. @@ -1942,19 +2299,37 @@ the user from the mailer." (set-buffer mailbuf) (buffer-string)))) ;; Remove some headers. + (message-encode-message-body) (save-restriction (message-narrow-to-headers) + ;; We (re)generate the Lines header. + (when (memq 'Lines message-required-mail-headers) + (message-generate-headers '(Lines))) ;; Remove some headers. - (message-remove-header message-ignored-mail-headers t)) + (message-remove-header message-ignored-mail-headers t) + (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)) - (funcall message-send-mail-function)) + (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?"))) + (mm-with-unibyte-current-buffer + (funcall message-send-mail-function)) + (message-send-mail-partially))) (kill-buffer tembuf)) (set-buffer mailbuf) (push 'mail message-sent-message-via))) @@ -1962,7 +2337,8 @@ the user from the mailer." (defun message-send-mail-with-sendmail () "Send off the prepared buffer with sendmail." (let ((errbuf (if message-interactive - (generate-new-buffer " sendmail errors") + (message-generate-new-buffer-clone-locals + " sendmail errors") 0)) resend-to-addresses delimline) (let ((case-fold-search t)) @@ -1987,7 +2363,7 @@ the user from the mailer." (set-buffer errbuf) (erase-buffer)))) (let ((default-directory "/") - (coding-system-for-write 'binary)) + (coding-system-for-write message-send-coding-system)) (apply 'call-process-region (append (list (point-min) (point-max) (if (boundp 'sendmail-program) @@ -1999,7 +2375,7 @@ the user from the mailer." ;; But some systems are more broken with -f, so ;; we'll let users override this. (if (null message-sendmail-f-is-evil) - (list "-f" (user-login-name))) + (list "-f" (message-make-address))) ;; These mean "report errors by mail" ;; and "deliver in background". (if (null message-interactive) '("-oem" "-odb")) @@ -2035,7 +2411,7 @@ to find out how to use this." (run-hooks 'message-send-mail-hook) ;; send the message (case - (let ((coding-system-for-write 'binary)) + (let ((coding-system-for-write message-send-coding-system)) (apply 'call-process-region 1 (point-max) message-qmail-inject-program nil nil nil @@ -2084,85 +2460,92 @@ to find out how to use this." (mh-send-letter))) (defun message-send-news (&optional arg) - (let ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) - (case-fold-search nil) - (method (if (message-functionp message-post-method) - (funcall message-post-method arg) - message-post-method)) - (messbuf (current-buffer)) - (message-syntax-checks - (if arg - (cons '(existing-newsgroups . disabled) - message-syntax-checks) - message-syntax-checks)) - result) - (save-restriction - (message-narrow-to-headers) - ;; Insert some headers. - (message-generate-headers message-required-news-headers) - ;; Let the user do all of the above. - (run-hooks 'message-header-hook)) - (message-cleanup-headers) - (if (not (message-check-news-syntax)) - (progn - ;;(message "Posting not performed") - nil) - (unwind-protect - (save-excursion - (set-buffer tembuf) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - ;; Avoid copying text props. - (insert (format - "%s" (save-excursion - (set-buffer messbuf) - (buffer-string)))) - ;; Remove some headers. - (save-restriction - (message-narrow-to-headers) + (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) + (case-fold-search nil) + (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 + (cons '(existing-newsgroups . disabled) + message-syntax-checks) + message-syntax-checks)) + (message-this-is-news t) + (message-posting-charset (gnus-setup-posting-charset + (save-restriction + (message-narrow-to-headers-or-head) + (message-fetch-field "Newsgroups")))) + result) + (if (not (message-check-news-body-syntax)) + nil + (save-restriction + (message-narrow-to-headers) + ;; Insert some headers. + (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 + (unwind-protect + (save-excursion + (set-buffer tembuf) + (buffer-disable-undo) + (erase-buffer) + ;; Avoid copying text props. + (insert (format + "%s" (save-excursion + (set-buffer messbuf) + (buffer-string)))) + (message-encode-message-body) ;; Remove some headers. - (message-remove-header message-ignored-news-headers t)) - (goto-char (point-max)) - ;; require one newline at the end. - (or (= (preceding-char) ?\n) - (insert ?\n)) - (let ((case-fold-search t)) - ;; Remove the delimiter. - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (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) - (setq result (gnus-request-post method))) - (kill-buffer tembuf)) - (set-buffer messbuf) - (if result - (push 'news message-sent-message-via) - (message "Couldn't send message via news: %s" - (nnheader-get-report (car method))) - nil)))) + (save-restriction + (message-narrow-to-headers) + ;; We (re)generate the Lines header. + (when (memq 'Lines message-required-mail-headers) + (message-generate-headers '(Lines))) + ;; Remove some headers. + (message-remove-header message-ignored-news-headers t) + (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)) + (let ((case-fold-search t)) + ;; Remove the delimiter. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (backward-char 1)) + (run-hooks 'message-send-news-hook) + (gnus-open-server method) + (setq result (let ((mail-header-separator "")) + (gnus-request-post method)))) + (kill-buffer tembuf)) + (set-buffer messbuf) + (if result + (push 'news message-sent-message-via) + (message "Couldn't send message via news: %s" + (nnheader-get-report (car method))) + nil))))) ;;; ;;; Header generation & syntax checking. ;;; -(defmacro message-check (type &rest forms) - "Eval FORMS if TYPE is to be checked." - `(or (message-check-element ,type) - (save-excursion - ,@forms))) - -(put 'message-check 'lisp-indent-function 1) -(put 'message-check 'edebug-form-spec '(form body)) - (defun message-check-element (type) "Returns non-nil if this type is not to be checked." (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me) @@ -2176,17 +2559,23 @@ to find out how to use this." (save-excursion (save-restriction (widen) - (and - ;; We narrow to the headers and check them first. - (save-excursion - (save-restriction - (message-narrow-to-headers) - (message-check-news-header-syntax))) - ;; Check the body. - (message-check-news-body-syntax))))) + ;; We narrow to the headers and check them first. + (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-check-news-header-syntax)))))) (defun message-check-news-header-syntax () (and + ;; Check Newsgroups header. + (message-check 'newsgroups + (let ((group (message-fetch-field "newsgroups"))) + (or + (and group + (not (string-match "\\`[ \t]*\\'" group))) + (ignore + (message + "The newsgroups field is empty or missing. Posting is denied."))))) ;; Check the Subject header. (message-check 'subject (let* ((case-fold-search t) @@ -2265,8 +2654,12 @@ to find out how to use this." (let* ((case-fold-search t) (message-id (message-fetch-field "message-id" t))) (or (not message-id) + ;; Is there an @ in the ID? (and (string-match "@" message-id) - (string-match "@[^\\.]*\\." message-id)) + ;; Is there a dot in the ID? + (string-match "@[^.]*\\." message-id) + ;; Does the ID end with a dot? + (not (string-match "\\.>" message-id))) (y-or-n-p (format "The Message-ID looks strange: \"%s\". Really post? " message-id))))) @@ -2345,12 +2738,15 @@ to find out how to use this." (message-check 'from (let* ((case-fold-search t) (from (message-fetch-field "from")) - (ad (nth 1 (mail-extract-address-components from)))) + ad) (cond ((not from) (message "There is no From line. Posting is denied.") nil) - ((or (not (string-match "@[^\\.]*\\." ad)) ;larsi@ifi + ((or (not (string-match + "@[^\\.]*\\." + (setq ad (nth 1 (mail-extract-address-components + from))))) ;larsi@ifi (string-match "\\.\\." ad) ;larsi@ifi..uio (string-match "@\\." ad) ;larsi@.ifi.uio (string-match "\\.$" ad) ;larsi@ifi.uio. @@ -2391,7 +2787,7 @@ to find out how to use this." (y-or-n-p "Empty article. Really post? ")))) ;; Check for control characters. (message-check 'control-chars - (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t) + (if (re-search-forward "[\000-\007\013\015-\032\034-\037\200-\237]" nil t) (y-or-n-p "The article contains control characters. Really post? ") t)) @@ -2406,22 +2802,31 @@ to find out how to use this." (message-check 'new-text (or (not message-checksum) - (not (and (eq (message-checksum) (car message-checksum)) - (eq (buffer-size) (cdr message-checksum)))) + (not (eq (message-checksum) message-checksum)) (y-or-n-p "It looks like no new text has been added. Really post? "))) ;; 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)) + ;; 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." @@ -2433,7 +2838,7 @@ to find out how to use this." (while (not (eobp)) (when (not (looking-at "[ \t\n]")) (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1) - (following-char)))) + (char-after)))) (forward-char 1))) sum)) @@ -2444,7 +2849,6 @@ to find out how to use this." list file) (save-excursion (set-buffer (get-buffer-create " *message temp*")) - (buffer-disable-undo (current-buffer)) (erase-buffer) (insert-buffer-substring buf) (save-restriction @@ -2452,9 +2856,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)) @@ -2474,7 +2888,6 @@ to find out how to use this." (rmail-output file 1 nil t) (let ((mail-use-rfc822 t)) (rmail-output file 1 t t)))))) - (kill-buffer (current-buffer))))) (defun message-output (filename) @@ -2516,11 +2929,24 @@ to find out how to use this." (when (re-search-forward ",+$" nil t) (replace-match "" t t)))))) -(defun message-make-date () - "Make a valid data header." - (let ((now (current-time))) - (timezone-make-date-arpa-standard - (current-time-string now) (current-time-zone now)))) +(defun message-make-date (&optional now) + "Make a valid data header. +If NOW, use that time instead." + (let* ((now (or now (current-time))) + (zone (nth 8 (decode-time now))) + (sign "+")) + (when (< zone 0) + (setq sign "-") + (setq zone (- zone))) + (concat + (format-time-string "%d" now) + ;; The month name of the %b spec is locale-specific. Pfff. + (format " %s " + (capitalize (car (rassoc (nth 4 (decode-time now)) + parse-time-months)))) + (format-time-string "%Y %H:%M:%S " now) + ;; We do all of this because XEmacs doesn't have the %z spec. + (format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60))))) (defun message-make-message-id () "Make a unique Message-ID." @@ -2587,9 +3013,9 @@ to find out how to use this." "Make an Organization header." (let* ((organization (when message-user-organization - (if (message-functionp message-user-organization) - (funcall message-user-organization) - message-user-organization)))) + (if (message-functionp message-user-organization) + (funcall message-user-organization) + message-user-organization)))) (save-excursion (message-set-work-buffer) (cond ((stringp organization) @@ -2618,16 +3044,7 @@ to find out how to use this." (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 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." @@ -2643,9 +3060,7 @@ to find out how to use this." ;; Add the future to current. (setcar current (+ (car current) (round (/ future (expt 2 16))))) (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16)))) - ;; Return the date in the future in UT. - (timezone-make-date-arpa-standard - (current-time-string current) (current-time-zone current) '(0 "UT")))) + (message-make-date current))) (defun message-make-path () "Return uucp path." @@ -2783,9 +3198,7 @@ Headers already prepared in the buffer are not modified." (To nil) (Distribution (message-make-distribution)) (Lines (message-make-lines)) - (X-Newsreader message-newsreader) - (X-Mailer (and (not (message-fetch-field "X-Newsreader")) - message-mailer)) + (User-Agent message-newsreader) (Expires (message-make-expires)) (case-fold-search t) header value elem) @@ -2813,14 +3226,20 @@ Headers already prepared in the buffer are not modified." (setq header (car elem))) (setq header elem)) (when (or (not (re-search-forward - (concat "^" (downcase (symbol-name header)) ":") + (concat "^" + (regexp-quote + (downcase + (if (stringp header) + header + (symbol-name header)))) + ":") nil t)) (progn ;; The header was found. We insert a space after the ;; colon, if there is none. - (if (/= (following-char) ? ) (insert " ") (forward-char 1)) + (if (/= (char-after) ? ) (insert " ") (forward-char 1)) ;; Find out whether the header is empty... - (looking-at "[ \t]*$"))) + (looking-at "[ \t]*\n[^ \t]"))) ;; So we find out what value we should insert. (setq value (cond @@ -2842,7 +3261,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 @@ -2855,7 +3274,8 @@ Headers already prepared in the buffer are not modified." (progn ;; This header didn't exist, so we insert it. (goto-char (point-max)) - (insert (symbol-name header) ": " value "\n") + (insert (if (stringp header) header (symbol-name header)) + ": " value "\n") (forward-line -1)) ;; The value of this header was empty, so we clear ;; totally and insert the new value. @@ -2890,7 +3310,7 @@ Headers already prepared in the buffer are not modified." (insert "Original-") (beginning-of-line)) (when (or (message-news-p) - (string-match "^[^@]@.+\\..+" secure-sender)) + (string-match "@.+\\.." secure-sender)) (insert "Sender: " secure-sender "\n"))))))) (defun message-insert-courtesy-copy () @@ -2926,7 +3346,7 @@ Headers already prepared in the buffer are not modified." (goto-char (point-min)) (while (not (eobp)) (skip-chars-forward "^,\"" (point-max)) - (if (or (= (following-char) ?,) + (if (or (eq (char-after) ?,) (eobp)) (when (not quoted) (if (and (> (current-column) 78) @@ -2946,7 +3366,7 @@ Headers already prepared in the buffer are not modified." (defun message-fill-header (header value) (let ((begin (point)) - (fill-column 990) + (fill-column 78) (fill-prefix "\t")) (insert (capitalize (symbol-name header)) ": " @@ -2965,6 +3385,64 @@ Headers already prepared in the buffer are not modified." (replace-match " " t t)) (goto-char (point-max))))) +(defun message-shorten-1 (list cut surplus) + ;; Cut SURPLUS elements out of LIST, beginning with CUTth one. + (setcdr (nthcdr (- cut 2) list) + (nthcdr (+ (- cut 2) surplus 1) list))) + +(defun message-shorten-references (header references) + "Trim REFERENCES to be less than 31 Message-ID long, and fold them. +If folding is disallowed, also check that the REFERENCES are less +than 988 characters long, and if they are not, trim them until they are." + (let ((maxcount 31) + (count 0) + (cut 6) + refs) + (with-temp-buffer + (insert references) + (goto-char (point-min)) + ;; Cons a list of valid references. + (while (re-search-forward "<[^>]+>" nil t) + (push (match-string 0) refs)) + (setq refs (nreverse refs) + count (length refs))) + + ;; If the list has more than MAXCOUNT elements, trim it by + ;; removing the CUTth element and the required number of + ;; elements that follow. + (when (> count maxcount) + (let ((surplus (- count maxcount))) + (message-shorten-1 refs cut surplus) + (decf count surplus))) + + ;; If folding is disallowed, make sure the total length (including + ;; the spaces between) will be less than MAXSIZE characters. + ;; + ;; 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))) + (surplus 0) + (ptr (nthcdr (1- cut) refs))) + ;; Decide how many elements to cut off... + (while (> totalsize maxsize) + (decf totalsize (1+ (length (car ptr)))) + (incf surplus) + (setq ptr (cdr ptr))) + ;; ...and do it. + (when (> surplus 0) + (message-shorten-1 refs cut surplus)))) + + ;; Finally, collect the references back into a string and insert + ;; it into the buffer. + (let ((refstring (mapconcat #'identity refs " "))) + (if (and message-this-is-news message-cater-to-broken-inn) + (insert (capitalize (symbol-name header)) ": " + refstring "\n") + (message-fill-header header refstring))))) + (defun message-position-point () "Move point to where the user probably wants to find it." (message-narrow-to-headers) @@ -2973,7 +3451,7 @@ Headers already prepared in the buffer are not modified." (search-backward ":" ) (widen) (forward-char 1) - (if (= (following-char) ? ) + (if (eq (char-after) ? ) (forward-char 1) (insert " "))) (t @@ -2987,14 +3465,24 @@ Headers already prepared in the buffer are not modified." (defun message-buffer-name (type &optional to group) "Return a new (unique) buffer name based on TYPE and TO." (cond + ;; Generate a new buffer name The Message Way. + ((eq message-generate-new-buffers 'unique) + (generate-new-buffer-name + (concat "*" type + (if to + (concat " to " + (or (car (mail-extract-address-components to)) + to) "") + "") + (if (and group (not (string= group ""))) (concat " on " group) "") + "*"))) ;; Check whether `message-generate-new-buffers' is a function, ;; and if so, call it. ((message-functionp message-generate-new-buffers) (funcall message-generate-new-buffers type to group)) - ;; Generate a new buffer name The Message Way. - (message-generate-new-buffers + ((eq message-generate-new-buffers 'unsent) (generate-new-buffer-name - (concat "*" type + (concat "*unsent " type (if to (concat " to " (or (car (mail-extract-address-components to)) @@ -3017,9 +3505,9 @@ Headers already prepared in the buffer are not modified." (not (y-or-n-p "Message already being composed; erase? "))) (error "Message being composed"))) - (set-buffer (pop-to-buffer name)))) - (erase-buffer) - (message-mode)) + (set-buffer (pop-to-buffer name))) + (erase-buffer) + (message-mode))) (defun message-do-send-housekeeping () "Kill old message buffers." @@ -3037,7 +3525,7 @@ Headers already prepared in the buffer are not modified." ;; Rename the buffer. (if message-send-rename-function (funcall message-send-rename-function) - (when (string-match "\\`\\*" (buffer-name)) + (when (string-match "\\`\\*\\(unsent \\)?" (buffer-name)) (rename-buffer (concat "*sent " (substring (buffer-name) (match-end 0))) t))) ;; Push the current buffer onto the list. @@ -3099,6 +3587,8 @@ Headers already prepared in the buffer are not modified." (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) @@ -3108,9 +3598,15 @@ Headers already prepared in the buffer are not modified." (defun message-set-auto-save-file-name () "Associate the message buffer with a file in the drafts directory." - (when message-autosave-directory - (setq message-draft-article (nndraft-request-associate-buffer "drafts")) - (clear-visited-file-modtime))) + (when message-auto-save-directory + (if (gnus-alive-p) + (setq message-draft-article + (nndraft-request-associate-buffer "drafts")) + (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) + (setq buffer-file-coding-system message-draft-coding-system))) (defun message-disassociate-draft () "Disassociate the message buffer from the drafts directory." @@ -3118,6 +3614,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)))))))) + ;;; @@ -3128,7 +3641,8 @@ Headers already prepared in the buffer are not modified." (defun message-mail (&optional to subject other-headers continue switch-function yank-action send-actions) - "Start editing a mail message to be sent." + "Start editing a mail message to be sent. +OTHER-HEADERS is an alist of header/value pairs." (interactive) (let ((message-this-is-mail t)) (message-pop-to-buffer (message-buffer-name "mail" to)) @@ -3146,15 +3660,79 @@ Headers already prepared in the buffer are not modified." (message-setup `((Newsgroups . ,(or newsgroups "")) (Subject . ,(or subject "")))))) +(defun message-get-reply-headers (wide &optional to-address) + (let (follow-to mct never-mct from to cc reply-to 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")) + + ;; Handle special values of Mail-Copies-To. + (when mct + (cond ((or (equal (downcase mct) "never") + (equal (downcase mct) "nobody")) + (setq never-mct t) + (setq mct nil)) + ((or (equal (downcase mct) "always") + (equal (downcase mct) "poster")) + (setq mct (or 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))) + (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) "")) + (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 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 ignore-reply-to) +(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 (inhibit-point-motion-hooks t) - mct never-mct gnus-warning) + (message-this-is-mail t) + gnus-warning) (save-restriction (message-narrow-to-head) ;; Allow customizations to have their say. @@ -3167,79 +3745,26 @@ Headers already prepared in the buffer are not modified." (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") - subject (or (message-fetch-field "subject") "none") - to (message-fetch-field "to") - cc (message-fetch-field "cc") - mct (message-fetch-field "mail-copies-to") - reply-to (unless ignore-reply-to (message-fetch-field "reply-to")) + (setq message-id (message-fetch-field "message-id" t) references (message-fetch-field "references") - message-id (message-fetch-field "message-id" t)) - ;; Remove any (buggy) Re:'s that are present and make a - ;; proper one. - (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject) - (setq subject (substring subject (match-end 0)))) - (setq subject (concat "Re: " subject)) + 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 (concat "Re: " (message-strip-subject-re subject))) - (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) - (string-match "<[^>]+>" gnus-warning)) - (setq message-id (match-string 0 gnus-warning))) + (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) + (string-match "<[^>]+>" gnus-warning)) + (setq message-id (match-string 0 gnus-warning))) - ;; Handle special values of Mail-Copies-To. - (when mct - (cond ((equal (downcase mct) "never") - (setq never-mct t) - (setq mct nil)) - ((equal (downcase mct) "always") - (setq mct (or reply-to from))))) - - (unless follow-to - (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))) - (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) "")) - (goto-char (point-min)) - (while (re-search-forward "[ \t]+" nil t) - (replace-match " " t t)) - ;; Remove addresses that match `rmail-dont-reply-to-names'. - (insert (prog1 (rmail-dont-reply-to (buffer-string)) - (erase-buffer))) - (goto-char (point-min)) - ;; Perhaps Mail-Copies-To: never removed the only address? - (when (eobp) - (insert (or 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)))))) - (widen)) + (unless follow-to + (setq follow-to (message-get-reply-headers wide to-address)))) - (message-pop-to-buffer (message-buffer-name - (if wide "wide reply" "reply") from - (if wide to-address nil))) + (message-pop-to-buffer + (message-buffer-name + (if wide "wide reply" "reply") from + (if wide to-address nil))) (setq message-reply-headers (vector 0 subject from date message-id references 0 0 "")) @@ -3254,16 +3779,17 @@ Headers already prepared in the buffer are not modified." cur))) ;;;###autoload -(defun message-wide-reply (&optional to-address ignore-reply-to) +(defun message-wide-reply (&optional to-address) "Make a \"wide\" reply to the message in the current buffer." (interactive) - (message-reply to-address t ignore-reply-to)) + (message-reply to-address t)) ;;;###autoload (defun message-followup (&optional to-newsgroups) "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 references message-id follow-to @@ -3298,11 +3824,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 "^[ \t]*[Rr][Ee]:[ \t]*" 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)) @@ -3359,8 +3883,10 @@ responses here are directed to other newsgroups.")) `((References . ,(concat (or references "") (and references " ") (or message-id ""))))) ,@(when (and mct - (not (equal (downcase mct) "never"))) - (list (cons 'Cc (if (equal (downcase mct) "always") + (not (or (equal (downcase mct) "never") + (equal (downcase mct) "nobody")))) + (list (cons 'Cc (if (or (equal (downcase mct) "always") + (equal (downcase mct) "poster")) (or reply-to from "") mct))))) @@ -3371,32 +3897,40 @@ responses here are directed to other newsgroups.")) ;;;###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? ") - (let (from newsgroups message-id distribution buf) + (let (from newsgroups message-id distribution buf sender) (save-excursion - ;; Get header info. from original article. + ;; Get header info from original article. (save-restriction (message-narrow-to-head) (setq from (message-fetch-field "from") + sender (message-fetch-field "sender") newsgroups (message-fetch-field "newsgroups") message-id (message-fetch-field "message-id" t) distribution (message-fetch-field "distribution"))) ;; Make sure that this article was written by the user. - (unless (string-equal - (downcase (cadr (mail-extract-address-components from))) - (downcase (message-make-address))) + (unless (or (and sender + (string-equal + (downcase sender) + (downcase (message-make-sender)))) + (string-equal + (downcase (cadr (mail-extract-address-components from))) + (downcase (cadr (mail-extract-address-components + (message-make-from)))))) (error "This article is not yours")) ;; Make control message. - (setq buf (set-buffer (get-buffer-create " *message cancel*"))) - (buffer-disable-undo (current-buffer)) + (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 @@ -3404,12 +3938,14 @@ responses here are directed to other newsgroups.")) "") mail-header-separator "\n" message-cancel-message) - (message "Canceling your article...") - (if (let ((message-syntax-checks - 'dont-check-for-anything-just-trust-me)) - (funcall message-send-news-function)) - (message "Canceling your article...done")) - (kill-buffer buf))))) + (run-hooks 'message-cancel-hook) + (unless arg + (message "Canceling your article...") + (if (let ((message-syntax-checks + 'dont-check-for-anything-just-trust-me)) + (funcall message-send-news-function)) + (message "Canceling your article...done")) + (kill-buffer buf)))))) ;;;###autoload (defun message-supersede () @@ -3417,16 +3953,23 @@ responses here are directed to other newsgroups.")) This is done simply by taking the old article and adding a Supersedes header line with the old Message-ID." (interactive) - (let ((cur (current-buffer))) + (let ((cur (current-buffer)) + (sender (message-fetch-field "sender")) + (from (message-fetch-field "from"))) ;; Check whether the user owns the article that is to be superseded. - (unless (string-equal - (downcase (cadr (mail-extract-address-components - (message-fetch-field "from")))) - (downcase (message-make-address))) + (unless (or (and sender + (string-equal + (downcase sender) + (downcase (message-make-sender)))) + (string-equal + (downcase (cadr (mail-extract-address-components from))) + (downcase (cadr (mail-extract-address-components + (message-make-from)))))) (error "This article is not yours")) ;; 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 @@ -3448,6 +3991,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 @@ -3458,66 +4003,151 @@ header line with the old Message-ID." (insert-file-contents file-name nil))) (t (error "message-recover cancelled"))))) +;;; Washing Subject: + +(defun message-wash-subject (subject) + "Remove junk like \"Re:\", \"(fwd)\", etc. that was added to the subject by previous forwarders, replyers, etc." + (with-temp-buffer + (insert-string subject) + (goto-char (point-min)) + ;; strip Re/Fwd stuff off the beginning + (while (re-search-forward + "\\([Rr][Ee]:\\|[Ff][Ww][Dd]\\(\\[[0-9]*\\]\\)?:\\|[Ff][Ww]:\\)" nil t) + (replace-match "")) + + ;; and gnus-style forwards [foo@bar.com] subject + (goto-char (point-min)) + (while (re-search-forward "\\[[^ \t]*\\(@\\|\\.\\)[^ \t]*\\]" nil t) + (replace-match "")) + + ;; and off the end + (goto-char (point-max)) + (while (re-search-backward "([Ff][Ww][Dd])" nil t) + (replace-match "")) + + ;; and finally, any whitespace that was left-over + (goto-char (point-min)) + (while (re-search-forward "^[ \t]+" nil t) + (replace-match "")) + (goto-char (point-max)) + (while (re-search-backward "[ \t]+$" nil t) + (replace-match "")) + + (buffer-string))) + ;;; Forwarding messages. +(defun message-forward-subject-author-subject (subject) + "Generate a subject for a forwarded message. +The form is: [Source] Subject, where if the original message was mail, +Source is the sender, and if the original message was news, Source is +the list of newsgroups is was posted to." + (concat "[" + (or (message-fetch-field + (if (message-news-p) "newsgroups" "from")) + "(nowhere)") + "] " subject)) + +(defun message-forward-subject-fwd (subject) + "Generate a subject for a forwarded message. +The form is: Fwd: Subject, where Subject is the original subject of +the message." + (concat "Fwd: " subject)) + (defun message-make-forward-subject () "Return a Subject header suitable for the message in the current buffer." (save-excursion (save-restriction (current-buffer) (message-narrow-to-head) - (concat "[" (or (message-fetch-field - (if (message-news-p) "newsgroups" "from")) - "(nowhere)") - "] " (or (message-fetch-field "Subject") ""))))) + (let ((funcs message-make-forward-subject-function) + (subject (if message-wash-forwarded-subjects + (message-wash-subject + (or (message-fetch-field "Subject") "")) + (or (message-fetch-field "Subject") "")))) + ;; Make sure funcs is a list. + (and funcs + (not (listp funcs)) + (setq funcs (list funcs))) + ;; Apply funcs in order, passing subject generated by previous + ;; func to the next one. + (while funcs + (when (message-functionp (car funcs)) + (setq subject (funcall (car funcs) subject))) + (setq funcs (cdr funcs))) + 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 (message-make-forward-subject)) - art-beg) - (if news (message-news nil subject) (message-mail nil subject)) + (let* ((cur (current-buffer)) + (subject (if message-forward-show-mml + (message-make-forward-subject) + (mail-decode-encoded-word-string + (message-make-forward-subject)))) + art-beg) + (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 - (goto-char (point-max)) - (message-goto-body)) - ;; Make sure we're at the start of the line. - (unless (eolp) - (insert "\n")) - ;; Narrow to the area we are to insert. - (narrow-to-region (point) (point)) - ;; Insert the separators and the forwarded buffer. - (insert message-forward-start-separator) - (setq art-beg (point)) - (insert-buffer-substring cur) - (goto-char (point-max)) - (insert message-forward-end-separator) - (set-text-properties (point-min) (point-max) nil) - ;; Remove all unwanted headers. - (goto-char art-beg) - (narrow-to-region (point) (if (search-forward "\n\n" nil t) - (1- (point)) - (point))) - (goto-char (point-min)) - (message-remove-header message-included-forward-headers t nil t) - (widen) + (if message-forward-before-signature + (message-goto-body) + (goto-char (point-max))) + (if message-forward-as-mime + (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 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 digest + (insert "<#/multipart>\n") + (if message-forward-show-mml + (insert "<#/mml>\n") + (insert "<#/part>\n"))) + (insert "\n-------------------- End of forwarded message --------------------\n")) + (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 (defun message-resend (address) "Resend the current article to ADDRESS." - (interactive "sResend message to: ") + (interactive + (list (message-read-from-minibuffer "Resend message to: "))) (message "Resending message to %s..." address) (save-excursion (let ((cur (current-buffer)) beg) ;; We first set up a normal mail buffer. (set-buffer (get-buffer-create " *message resend*")) - (buffer-disable-undo (current-buffer)) (erase-buffer) (message-setup `((To . ,address))) ;; Insert our usual headers. @@ -3542,7 +4172,7 @@ Optional NEWS will use news to forward instead of mail." (goto-char (point-max))) (insert mail-header-separator) ;; Rename all old ("Also-")Resent headers. - (while (re-search-backward "^\\(Also-\\)?Resent-" beg t) + (while (re-search-backward "^\\(Also-\\)*Resent-" beg t) (beginning-of-line) (insert "Also-")) ;; Quote any "From " lines at the beginning. @@ -3550,44 +4180,42 @@ Optional NEWS will use news to forward instead of mail." (when (looking-at "From ") (replace-match "X-From-Line: ")) ;; Send it. - (message-send-mail) + (let ((message-inhibit-body-encoding t) + message-required-mail-headers) + (message-send-mail)) (kill-buffer (current-buffer))) (message "Resending message to %s...done" address))) ;;;###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) - (let ((cur (current-buffer)) + (let ((handles (mm-dissect-buffer t)) boundary) (message-pop-to-buffer (message-buffer-name "bounce")) - (insert-buffer-substring cur) - (undo-boundary) - (message-narrow-to-head) - (if (and (message-fetch-field "Mime-Version") - (setq boundary (message-fetch-field "Content-Type"))) - (if (string-match "boundary=\"\\([^\"]+\\)\"" boundary) - (setq boundary (concat (match-string 1 boundary) " *\n" - "Content-Type: message/rfc822")) - (setq boundary nil))) - (widen) - (goto-char (point-min)) - (search-forward "\n\n" nil t) - (or (and boundary - (re-search-forward boundary nil t) - (forward-line 2)) - (and (re-search-forward message-unsent-separator nil t) - (forward-line 1)) - (re-search-forward "^Return-Path:.*\n" nil t)) - ;; We remove everything before the bounced mail. - (delete-region - (point-min) - (if (re-search-forward "^[^ \n\t]+:" nil t) - (match-beginning 0) - (point))) + (if (stringp (car handles)) + ;; This is a MIME bounce. + (mm-insert-part (car (last handles))) + ;; This is a non-MIME bounce, so we try to remove things + ;; manually. + (mm-insert-part handles) + (undo-boundary) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (or (and (re-search-forward message-unsent-separator nil t) + (forward-line 1)) + (re-search-forward "^Return-Path:.*\n" nil t)) + ;; We remove everything before the bounced mail. + (delete-region + (point-min) + (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) @@ -3609,7 +4237,8 @@ you." (same-window-buffer-names nil) (same-window-regexps nil)) (message-pop-to-buffer (message-buffer-name "mail" to))) - (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))) + (let ((message-this-is-mail t)) + (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))) ;;;###autoload (defun message-mail-other-frame (&optional to subject) @@ -3621,7 +4250,8 @@ you." (same-window-buffer-names nil) (same-window-regexps nil)) (message-pop-to-buffer (message-buffer-name "mail" to))) - (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))) + (let ((message-this-is-mail t)) + (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))) ;;;###autoload (defun message-news-other-window (&optional newsgroups subject) @@ -3633,8 +4263,9 @@ you." (same-window-buffer-names nil) (same-window-regexps nil)) (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))) - (message-setup `((Newsgroups . ,(or newsgroups "")) - (Subject . ,(or subject ""))))) + (let ((message-this-is-news t)) + (message-setup `((Newsgroups . ,(or newsgroups "")) + (Subject . ,(or subject "")))))) ;;;###autoload (defun message-news-other-frame (&optional newsgroups subject) @@ -3646,8 +4277,9 @@ you." (same-window-buffer-names nil) (same-window-regexps nil)) (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))) - (message-setup `((Newsgroups . ,(or newsgroups "")) - (Subject . ,(or subject ""))))) + (let ((message-this-is-news t)) + (message-setup `((Newsgroups . ,(or newsgroups "")) + (Subject . ,(or subject "")))))) ;;; underline.el @@ -3666,7 +4298,7 @@ which specify the range to operate on." (goto-char (min start end)) (while (< (point) end1) (or (looking-at "[_\^@- ]") - (insert (following-char) "\b")) + (insert (char-after) "\b")) (forward-char 1))))) ;;;###autoload @@ -3680,13 +4312,13 @@ which specify the range to operate on." (move-marker end1 (max start end)) (goto-char (min start end)) (while (re-search-forward "\b" end1 t) - (if (eq (following-char) (char-after (- (point) 2))) + (if (eq (char-after) (char-after (- (point) 2))) (delete-char -2)))))) (defalias 'message-exchange-point-and-mark 'exchange-point-and-mark) ;; Support for toolbar -(when (string-match "XEmacs\\|Lucid" emacs-version) +(when (featurep 'xemacs) (require 'messagexmas)) ;;; Group name completion. @@ -3706,7 +4338,8 @@ Do a `tab-to-tab-stop' if not in those headers." (defvar gnus-active-hashtb) (defun message-expand-group () - "Expand the group name under point." (let* ((b (save-excursion + "Expand the group name under point." + (let* ((b (save-excursion (save-restriction (narrow-to-region (save-excursion @@ -3716,10 +4349,10 @@ Do a `tab-to-tab-stop' if not in those headers." (point)) (skip-chars-backward "^, \t\n") (point)))) (completion-ignore-case t) - (string (buffer-substring b (point))) + (string (buffer-substring b (progn (skip-chars-forward "^,\t\n ") + (point)))) (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb)) (completions (all-completions string hashtb)) - (cur (current-buffer)) comp) (delete-region b (point)) (cond @@ -3738,7 +4371,7 @@ Do a `tab-to-tab-stop' if not in those headers." (message "No matching groups") (save-selected-window (pop-to-buffer "*Completions*") - (buffer-disable-undo (current-buffer)) + (buffer-disable-undo) (let ((buffer-read-only nil)) (erase-buffer) (let ((standard-output (current-buffer))) @@ -3758,6 +4391,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)) @@ -3781,20 +4415,22 @@ regexp varstr." (let ((oldbuf (current-buffer))) (save-excursion (set-buffer (generate-new-buffer name)) - (message-clone-locals oldbuf) + (message-clone-locals oldbuf varstr) (current-buffer)))) -(defun message-clone-locals (buffer) +(defun message-clone-locals (buffer &optional varstr) "Clone the local variables from BUFFER to the current buffer." (let ((locals (save-excursion (set-buffer buffer) (buffer-local-variables))) - (regexp "^gnus\\|^nn\\|^message")) + (regexp "^gnus\\|^nn\\|^message\\|^user-mail-address")) (mapcar (lambda (local) (when (and (consp local) (car local) - (string-match regexp (symbol-name (car local)))) + (string-match regexp (symbol-name (car local))) + (or (null varstr) + (string-match varstr (symbol-name (car local))))) (ignore-errors (set (make-local-variable (car local)) (cdr local))))) @@ -3803,20 +4439,103 @@ 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)) +(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))) -(run-hooks 'message-load-hook) +;;; +;;; MIME functions +;;; + +(defvar message-inhibit-body-encoding nil) + +(defun message-encode-message-body () + (unless message-inhibit-body-encoding + (let ((mail-parse-charset (or mail-parse-charset + message-default-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"))))) + +(defun message-read-from-minibuffer (prompt) + "Read from the minibuffer while providing abbrev expansion." + (if (fboundp 'mail-abbrevs-setup) + (let ((mail-abbrev-mode-regexp "") + (minibuffer-setup-hook 'mail-abbrevs-setup)) + (read-from-minibuffer prompt)) + (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)) + (read-string prompt)))) + +(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")))) (provide 'message) +(run-hooks 'message-load-hook) + +;; Local Variables: +;; coding: iso-8859-1 +;; End: + ;;; message.el ends here