X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=ad8172826cb9b6a86eeba55f299b3d1b343ec9d8;hb=b14ba71ca00ad909b738bad1898f1908c0e6d2eb;hp=db77bcccccaecdc0325380fbd534f4d36122216d;hpb=f02a47aff393ee1726a1f120cfa0d377d191b900;p=elisp%2Fgnus.git- diff --git a/lisp/message.el b/lisp/message.el index db77bcc..ad81728 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -2,7 +2,10 @@ ;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen -;; Keywords: mail, news +;; MORIOKA Tomohiko +;; Shuhei KOBAYASHI +;; Keiichi Suzuki +;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -29,16 +32,19 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile + (require 'cl) + (require 'smtp) + ) (require 'mailheader) (require 'nnheader) -(require 'timezone) (require 'easymenu) (require 'custom) (if (string-match "XEmacs\\|Lucid" emacs-version) (require 'mail-abbrevs) (require 'mailabbrev)) +(require 'mime-edit) (defgroup message '((user-mail-address custom-variable) (user-full-name custom-variable)) @@ -98,6 +104,10 @@ :group 'message :group 'faces) +(defgroup message-frames nil + "Message frames" + :group 'message) + (defcustom message-directory "~/Mail/" "*Directory from which all other mail file variables are derived." :group 'message-various @@ -122,6 +132,11 @@ mailbox format." (function :tag "Other")) :group 'message-sending) +(defcustom message-encode-function 'message-maybe-encode + "*A function called to encode messages." + :group 'message-sending + :type 'function) + (defcustom message-courtesy-message "The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n" "*This is inserted at the start of a mailed copy of a posted message. @@ -172,11 +187,11 @@ shorten-followup-to existing-newsgroups buffer-file-name unchanged." (defcustom message-required-news-headers '(From Newsgroups Subject Date Message-ID (optional . Organization) Lines - (optional . X-Newsreader)) + (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 +199,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)) + (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)) @@ -222,6 +237,47 @@ any confusion." :group 'message-various :type 'regexp) +;;; Some sender agents encode the whole subject including leading "Re: ". +;;; And if followup agent does not decode it for some reason (e.g. unknown +;;; charset) and just add a new "Re: " in front of the encoded-word, the +;;; result will contain multiple "Re: "'s. +(defcustom message-subject-encoded-re-regexp + (concat + "^[ \t]*" + (regexp-quote "=?") + "[-!#$%&'*+0-9A-Z^_`a-z{|}~]+" ; charset + (regexp-quote "?") + "\\(" + "[Bb]" (regexp-quote "?") ; B encoding + "\\(\\(CQk\\|CSA\\|IAk\\|ICA\\)[Jg]\\)*" ; \([ \t][ \t][ \t]\)* + "\\(" + "[Uc][km]U6" ; [Rr][Ee]: + "\\|" + "\\(C[VX]\\|I[FH]\\)J[Fl]O[g-v]" ; [ \t][Rr][Ee]: + "\\|" + "\\(CQl\\|CSB\\|IAl\\|ICB\\)[Sy][RZ]T[o-r]" ; [ \t][ \t][Rr][Ee]: + "\\)" + "\\|" + "[Qb]" (regexp-quote "?") ; Q encoding + "\\(_\\|=09\\|=20\\)*" + "\\([Rr]\\|=[57]2\\)\\([Ee]\\|=[46]5\\)\\(:\\|=3[Aa]\\)" + "\\)" + ) + "*Regexp matching \"Re: \" in the subject line. +Unlike `message-subject-re-regexp', this regexp matches \"Re: \" within +an encoded-word." + :group 'message-various + :type 'regexp) + +(defcustom message-use-subject-re t + "*If t, remove any (buggy) \"Re: \"'s from the subject of the precursor +and add a new \"Re: \". If it is nil, use the subject \"as-is\". If it +is the symbol `guess', try to detect \"Re: \" within an encoded-word." + :group 'message-various + :type '(choice (const :tag "off" nil) + (const :tag "on" t) + (const guess))) + ;;;###autoload (defcustom message-signature-separator "^-- *$" "Regexp matching the signature separator." @@ -255,6 +311,15 @@ should return the new buffer name." :group 'message-buffers :type 'boolean) +(defcustom message-kill-buffer-query-function 'yes-or-no-p + "*A function called to query the user whether to kill buffer anyway or not. +If it is t, the buffer will be killed peremptorily." + :type '(radio (function-item yes-or-no-p) + (function-item y-or-n-p) + (function-item nnheader-Y-or-n-p) + (function :tag "Other" t)) + :group 'message-buffers) + (defvar gnus-local-organization) (defcustom message-user-organization (or (and (boundp 'gnus-local-organization) @@ -275,13 +340,13 @@ If t, use `message-user-organization-file'." :group 'message-headers) (defcustom message-forward-start-separator - "------- Start of forwarded message -------\n" + (concat (mime-make-tag "message" "rfc822") "\n") "*Delimiter inserted before forwarded messages." :group 'message-forwarding :type 'string) (defcustom message-forward-end-separator - "------- End of forwarded message -------\n" + (concat (mime-make-tag "text" "plain") "\n") "*Delimiter inserted after forwarded messages." :group 'message-forwarding :type 'string) @@ -292,12 +357,33 @@ If t, use `message-user-organization-file'." :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:" + "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^\\(Mail-\\)?Followup-To:\\|^\\(Mail-\\)?Reply-To:\\|^Mail-Copies-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-\\|^MIME-Version:" "*Regexp matching headers to be included in forwarded messages." :group 'message-forwarding :type 'regexp) -(defcustom message-ignored-resent-headers "^Return-receipt" +(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: + +* 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 '(radio (function-item message-forward-subject-author-subject) + (function-item message-forward-subject-fwd))) + +(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" "*All headers that match this regexp will be deleted when resending a message." :group 'message-interface :type 'regexp) @@ -321,16 +407,17 @@ variable `mail-header-separator'. Legal values include `message-send-mail-with-sendmail' (the default), `message-send-mail-with-mh', `message-send-mail-with-qmail' and -`smtpmail-send-it'." +`message-send-mail-with-smtp'." :type '(radio (function-item message-send-mail-with-sendmail) (function-item message-send-mail-with-mh) (function-item message-send-mail-with-qmail) - (function-item smtpmail-send-it) + (function-item message-send-mail-with-smtp) (function :tag "Other")) :group 'message-sending :group 'message-mail) -(defcustom message-send-news-function 'message-send-news +;; 1997-09-29 by MORIOKA Tomohiko +(defcustom message-send-news-function 'message-send-news-with-gnus "Function to call to send the current buffer as news. The headers should be delimited by a line whose contents match the variable `mail-header-separator'." @@ -367,8 +454,45 @@ always query the user whether to use the value. If it is the symbol `use', always use the value." :group 'message-interface :type '(choice (const :tag "ignore" nil) - (const use) - (const ask))) + (const :tag "maybe" t) + (const :tag "always" use) + (const :tag "ask" ask))) + +(defcustom message-use-mail-copies-to 'ask + "*Specifies what to do with Mail-Copies-To header. +If nil, always ignore the header. If it is t, use its value, but +query before using the value other than \"always\" or \"never\". +If it is the symbol `ask', always query the user whether to use +the value. If it is the symbol `use', always use the value." + :group 'message-interface + :type '(choice (const :tag "ignore" nil) + (const :tag "maybe" t) + (const :tag "always" use) + (const :tag "ask" ask))) + +(defcustom message-use-mail-followup-to 'ask + "*Specifies what to do with Mail-Followup-To header. +If nil, always ignore the header. If it is the symbol `ask', always +query the user whether to use the value. If it is t or the symbol +`use', always use the value." + :group 'message-interface + :type '(choice (const :tag "ignore" nil) + (const :tag "maybe" t) + (const :tag "always" use) + (const :tag "ask" ask))) + +;;; XXX: 'ask and 'use are not implemented yet. +(defcustom message-use-mail-reply-to 'ask + "*Specifies what to do with Mail-Reply-To/Reply-To header. +If nil, always ignore the header. If it is t or the symbol `use', use +its value. If it is the symbol `ask', always query the user whether to +use the value. Note that if \"Reply-To\" is marked as \"broken\", its value +is never used." + :group 'message-interface + :type '(choice (const :tag "ignore" nil) + (const :tag "maybe" t) + (const :tag "always" use) + (const :tag "ask" ask))) ;; stuff relating to broken sendmail in MMDF (defcustom message-sendmail-f-is-evil nil @@ -397,6 +521,7 @@ might set this variable to '(\"-f\" \"you@some.where\")." (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) @@ -416,7 +541,7 @@ variable isn't used." :group 'message-headers :type 'boolean) -(defcustom message-setup-hook nil +(defcustom message-setup-hook '(turn-on-mime-edit) "Normal hook, run each time a new outgoing message is initialized. The function `message-setup' runs this hook." :group 'message-various @@ -434,7 +559,7 @@ the signature is inserted." :group 'message-various :type 'hook) -(defcustom message-header-hook nil +(defcustom message-header-hook '(eword-encode-header) "Hook run in a message mode buffer narrowed to the headers." :group 'message-various :type 'hook) @@ -464,16 +589,12 @@ 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) (function :tag "Other")) :group 'message-insertion) @@ -529,8 +650,6 @@ If stringp, use this; if non-nil, use no host name (user name only)." (defvar message-reply-buffer nil) (defvar message-reply-headers nil) -(defvar message-newsreader nil) -(defvar message-mailer nil) (defvar message-sent-message-via nil) (defvar message-checksum nil) (defvar message-send-actions nil @@ -541,6 +660,9 @@ If stringp, use this; if non-nil, use no host name (user name only)." "A list of actions to be performed before killing a message buffer.") (defvar message-postpone-actions nil "A list of actions to be performed after postponing a message.") +(defvar message-original-frame nil) +(defvar message-parameter-alist nil) +(defvar message-startup-parameter-alist nil) (define-widget 'message-header-lines 'text "All header lines must be LFD terminated." @@ -595,6 +717,10 @@ actually occur." :group 'message-sending :type 'sexp) +;;; XXX: This symbol is overloaded! See below. +(defvar message-user-agent nil + "String of the form of PRODUCT/VERSION. Used for User-Agent header field.") + ;; Ignore errors in case this is used in Emacs 19. ;; Don't use ignore-errors because this is copied into loaddefs.el. ;;;###autoload @@ -765,7 +891,10 @@ Defaults to `text-mode-abbrev-table'.") `((,(concat "^\\([Tt]o:\\)" content) (1 'message-header-name-face) (2 'message-header-to-face nil t)) - (,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content) + (,(concat "^\\([GBF]?[Cc][Cc]:\\|[Rr]eply-[Tt]o:\\|" + "[Mm]ail-[Cc]opies-[Tt]o:\\|" + "[Mm]ail-[Rr]eply-[Tt]o:\\|" + "[Mm]ail-[Ff]ollowup-[Tt]o:\\)" content) (1 'message-header-name-face) (2 'message-header-cc-face nil t)) (,(concat "^\\([Ss]ubject:\\)" content) @@ -825,8 +954,24 @@ The cdr of ech entry is a function for applying the face to a region.") :group 'message-various :type 'hook) +(defcustom message-use-multi-frames nil + "Make new frame when sending messages." + :group 'message-frames + :type 'boolean) + +(defcustom message-delete-frame-on-exit nil + "Delete frame after sending messages." + :group 'message-frames + :type '(choice (const :tag "off" nil) + (const :tag "always" t) + (const :tag "ask" ask))) + +(defvar message-send-coding-system 'binary + "Coding system to encode outgoing mail.") + ;;; Internal variables. +(defvar message-default-charset nil) (defvar message-buffer-list nil) (defvar message-this-is-news nil) (defvar message-this-is-mail nil) @@ -915,9 +1060,9 @@ The cdr of ech entry is a function for applying the face to a region.") (Lines) (Expires) (Message-ID) - (References . message-shorten-references) - (X-Mailer) - (X-Newsreader)) + ;; (References . message-shorten-references) + (References . message-fill-header) + (User-Agent)) "Alist used for formatting headers.") (eval-and-compile @@ -927,12 +1072,12 @@ The cdr of ech entry is a function for applying the face to a region.") (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 'mail-abbrev-in-expansion-header-p "mailabbrev") (autoload 'nndraft-request-associate-buffer "nndraft") (autoload 'nndraft-request-expire-articles "nndraft") (autoload 'gnus-open-server "gnus-int") (autoload 'gnus-request-post "gnus-int") + (autoload 'gnus-copy-article-buffer "gnus-msg") (autoload 'gnus-alive-p "gnus-util") (autoload 'rmail-output "rmail")) @@ -990,7 +1135,7 @@ The cdr of ech entry is a function for applying the face to a region.") (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)))) @@ -1000,7 +1145,23 @@ The cdr of ech entry is a function for applying the face to a region.") (let* ((inhibit-point-motion-hooks 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))) + 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." @@ -1017,11 +1178,12 @@ The cdr of ech entry is a function for applying the face to a region.") (defun message-fetch-reply-field (header) "Fetch FIELD from the message we're replying to." - (when (and message-reply-buffer - (buffer-name message-reply-buffer)) - (save-excursion - (set-buffer message-reply-buffer) - (message-fetch-field header)))) + (let ((buffer (message-get-reply-buffer))) + (when (and buffer + (buffer-name buffer)) + (save-excursion + (set-buffer buffer) + (message-fetch-field header))))) (defun message-set-work-buffer () (if (get-buffer " *message work*") @@ -1029,8 +1191,7 @@ The cdr of ech entry is a function for applying the face to a region.") (set-buffer " *message work*") (erase-buffer)) (set-buffer (get-buffer-create " *message work*")) - (kill-all-local-variables) - (buffer-disable-undo (current-buffer)))) + (kill-all-local-variables))) (defun message-functionp (form) "Return non-nil if FORM is funcallable." @@ -1050,7 +1211,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) @@ -1090,7 +1251,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)) @@ -1099,6 +1261,21 @@ 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." (and (not message-this-is-mail) @@ -1162,6 +1339,22 @@ Return the number of headers removed." (1+ max))))) (message-sort-headers-1)))) +(defun message-eval-parameter (parameter) + (condition-case () + (if (symbolp parameter) + (if (functionp parameter) + (funcall parameter) + (eval parameter)) + parameter) + (error nil))) + +(defun message-get-reply-buffer () + (message-eval-parameter message-reply-buffer)) + +(defun message-get-original-reply-buffer () + (message-eval-parameter + (cdr (assq 'original-buffer message-parameter-alist)))) + ;;; @@ -1181,7 +1374,9 @@ Return the number of headers removed." (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc) (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc) (define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject) - (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to) + ;; (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to) + (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-mail-reply-to) + (define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to) (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups) (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution) (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to) @@ -1210,7 +1405,9 @@ 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 "\t" 'message-tab)) + (define-key message-mode-map "\t" 'message-tab) + + (define-key message-mode-map "\C-xk" 'message-kill-buffer)) (easy-menu-define message-mode-menu message-mode-map "Message Menu." @@ -1229,7 +1426,8 @@ Return the number of headers removed." ["Spellcheck" ispell-message 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 "" @@ -1241,6 +1439,9 @@ Return the number of headers removed." ["Subject" message-goto-subject t] ["Cc" message-goto-cc t] ["Reply-To" message-goto-reply-to t] + ["Mail-Reply-To" message-goto-mail-reply-to t] + ["Mail-Followup-To" message-goto-mail-followup-to t] + ["Mail-Copies-To" message-goto-mail-copies-to t] ["Summary" message-goto-summary t] ["Keywords" message-goto-keywords t] ["Newsgroups" message-goto-newsgroups t] @@ -1263,6 +1464,7 @@ C-c C-f move to a header field (and create it if there isn't): C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution + C-c C-f C-m move to Mail-Followup-To C-c C-f C-f move to Followup-To C-c C-t message-insert-to (add a To header to a news followup) C-c C-n message-insert-newsgroups (add a Newsgroup header to a news reply) @@ -1302,28 +1504,29 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." facemenu-remove-face-function t) (make-local-variable 'paragraph-separate) (make-local-variable 'paragraph-start) + ;; `-- ' precedes the signature. `-----' appears at the start of the + ;; lines that delimit forwarded messages. + ;; Lines containing just >= 3 dashes, perhaps after whitespace, + ;; are also sometimes used and should be separators. (setq paragraph-start (concat (regexp-quote mail-header-separator) - "$\\|[ \t]*[-_][-_][-_]+$\\|" - "-- $\\|" + "$\\|[ \t]*[a-z0-9A-Z]*>+[ \t]*$\\|[ \t]*$\\|" + "-- $\\|---+$\\|" + page-delimiter ;;!!! 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)) + "[> " (regexp-quote message-yank-prefix) "]+$")) + (setq paragraph-separate paragraph-start) (make-local-variable 'message-reply-headers) (setq message-reply-headers nil) - (make-local-variable 'message-newsreader) - (make-local-variable 'message-mailer) + (make-local-variable 'message-user-agent) (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) + (make-local-variable 'message-parameter-alist) + (setq message-parameter-alist + (copy-sequence message-startup-parameter-alist)) ;;(when (fboundp 'mail-hist-define-keys) ;; (mail-hist-define-keys)) (when (string-match "XEmacs\\|Lucid" emacs-version) @@ -1334,7 +1537,7 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (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) (unless (string-match "XEmacs" emacs-version) (set (make-local-variable 'font-lock-defaults) @@ -1388,6 +1591,21 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (interactive) (message-position-on-field "Reply-To" "Subject")) +(defun message-goto-mail-reply-to () + "Move point to the Mail-Reply-To header." + (interactive) + (message-position-on-field "Mail-Reply-To" "Subject")) + +(defun message-goto-mail-followup-to () + "Move point to the Mail-Followup-To header." + (interactive) + (message-position-on-field "Mail-Followup-To" "Subject")) + +(defun message-goto-mail-copies-to () + "Move point to the Mail-Copies-To header." + (interactive) + (message-position-on-field "Mail-Copies-To" "Subject")) + (defun message-goto-newsgroups () "Move point to the Newsgroups header." (interactive) @@ -1420,13 +1638,22 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (goto-char (point-min)) (search-forward (concat "\n" mail-header-separator "\n") nil t)) +(defun message-goto-eoh () + "Move point to the end of the headers." + (interactive) + (message-goto-body) + (forward-line -2)) + (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)) @@ -1466,16 +1693,17 @@ 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." @@ -1573,9 +1801,10 @@ text was killed." ;; 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))) + (when (< (char-after b) 255) + (subst-char-in-region + b (1+ b) (char-after b) + (aref message-caesar-translation-table (char-after b)))) (incf b)))) (defun message-make-caesar-translation-table (n) @@ -1699,6 +1928,7 @@ However, if `message-yank-prefix' is non-nil, insert that prefix on each line." (forward-line 1)))) (goto-char start))) +(defvar gnus-article-copy) (defun message-yank-original (&optional arg) "Insert the message being replied to, if any. Puts point before the text and mark after. @@ -1710,17 +1940,18 @@ This function uses `message-cite-function' to do the actual citing. Just \\[universal-argument] as argument means don't indent, insert no prefix, and don't delete any headers." (interactive "P") - (let ((modified (buffer-modified-p))) - (when (and message-reply-buffer + (let ((modified (buffer-modified-p)) + (buffer (message-get-reply-buffer))) + (when (and buffer message-cite-function) - (delete-windows-on message-reply-buffer t) - (insert-buffer message-reply-buffer) + (delete-windows-on buffer t) + (insert-buffer buffer) (funcall message-cite-function) (message-exchange-point-and-mark) (unless (bolp) (insert ?\n)) (unless modified - (setq message-checksum (cons (message-checksum) (buffer-size))))))) + (setq message-checksum (message-checksum)))))) (defun message-cite-original-without-signature () "Cite function in the standard Message manner." @@ -1733,6 +1964,11 @@ prefix, and don't delete any headers." (list message-indent-citation-function))))) (goto-char end) (when (re-search-backward "^-- $" 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 @@ -1742,21 +1978,25 @@ 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)) + (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))))) (defun message-insert-citation-line () "Function that inserts a simple citation line." @@ -1819,11 +2059,18 @@ The text will also be indented the normal way." ;;; Sending messages ;;; +;; Avoid byte-compile warning. +(defvar message-encoding-buffer nil) +(defvar message-edit-buffer nil) +(defvar message-mime-mode nil) + (defun message-send-and-exit (&optional arg) "Send message like `message-send', then, if no errors, exit from mail buffer." (interactive "P") (let ((buf (current-buffer)) - (actions message-exit-actions)) + (actions message-exit-actions) + (frame (selected-frame)) + (org-frame message-original-frame)) (when (and (message-send arg) (buffer-name buf)) (if message-kill-buffer-on-exit @@ -1831,7 +2078,9 @@ 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) + (message-delete-frame frame org-frame) + t))) (defun message-dont-send () "Don't send the message you have been editing." @@ -1846,11 +2095,36 @@ The text will also be indented the normal way." "Kill the current buffer." (interactive) (when (or (not (buffer-modified-p)) - (yes-or-no-p "Message modified; kill anyway? ")) - (let ((actions message-kill-actions)) + (eq t message-kill-buffer-query-function) + (funcall message-kill-buffer-query-function + "The buffer modified; kill anyway? ")) + (let ((actions message-kill-actions) + (frame (selected-frame)) + (org-frame message-original-frame)) (setq buffer-file-name nil) (kill-buffer (current-buffer)) - (message-do-actions actions)))) + (message-do-actions actions) + (message-delete-frame frame org-frame))) + (message "")) + +(defun message-delete-frame (frame org-frame) + "Delete frame for editing message." + (when (and (or (and (featurep 'xemacs) + (not (eq 'tty (device-type)))) + window-system + (>= emacs-major-version 20)) + (or (and (eq message-delete-frame-on-exit t) + (select-frame frame) + (or (eq frame org-frame) + (prog1 + (y-or-n-p "Delete this frame?") + (message "")))) + (and (eq message-delete-frame-on-exit 'ask) + (select-frame frame) + (prog1 + (y-or-n-p "Delete this frame?") + (message ""))))) + (delete-frame frame))) (defun message-bury (buffer) "Bury this mail buffer." @@ -1877,23 +2151,32 @@ the user from the mailer." (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) + (let ((message-encoding-buffer + (message-generate-new-buffer-clone-locals " message encoding")) + (message-edit-buffer (current-buffer)) + (message-mime-mode mime-edit-mode-flag) + (alist message-send-method-alist) (success t) elem sent) - (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))) + (save-excursion + (set-buffer message-encoding-buffer) + (erase-buffer) + (insert-buffer message-edit-buffer) + (funcall message-encode-function) + (message-fix-before-sending) + (while (and success + (setq elem (pop alist))) + (when (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) @@ -1916,14 +2199,20 @@ the user from the mailer." (defun message-send-via-news (arg) "Send the current message via news." - (funcall message-send-news-function arg)) + (message-send-news arg)) (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." @@ -1950,8 +2239,7 @@ the user from the mailer." (require 'mail-utils) (let ((tembuf (message-generate-new-buffer-clone-locals " message temp")) (case-fold-search nil) - (news (message-news-p)) - (mailbuf (current-buffer))) + (news (message-news-p))) (save-restriction (message-narrow-to-headers) ;; Insert some headers. @@ -1964,11 +2252,7 @@ the user from the mailer." (save-excursion (set-buffer tembuf) (erase-buffer) - ;; Avoid copying text props. - (insert (format - "%s" (save-excursion - (set-buffer mailbuf) - (buffer-string)))) + (insert-buffer message-encoding-buffer) ;; Remove some headers. (save-restriction (message-narrow-to-headers) @@ -1982,9 +2266,27 @@ the user from the mailer." (or (message-fetch-field "cc") (message-fetch-field "to"))) (message-insert-courtesy-copy)) +;; (mime-edit-maybe-split-and-send +;; (function +;; (lambda () +;; (interactive) +;; (funcall message-send-mail-function) +;; ))) + (mime-edit-maybe-split-and-send + (function + (lambda () + (interactive) + (save-restriction + (std11-narrow-to-header mail-header-separator) + (goto-char (point-min)) + (when (re-search-forward "^Message-Id:" nil t) + (delete-region (match-end 0)(std11-field-end)) + (insert (concat " " (message-make-message-id))) + )) + (funcall message-send-mail-function)))) (funcall message-send-mail-function)) (kill-buffer tembuf)) - (set-buffer mailbuf) + (set-buffer message-edit-buffer) (push 'mail message-sent-message-via))) (defun message-send-mail-with-sendmail () @@ -1992,11 +2294,12 @@ the user from the mailer." (let ((errbuf (if message-interactive (generate-new-buffer " sendmail errors") 0)) - resend-to-addresses delimline) + resend-addresses delimline) (let ((case-fold-search t)) (save-restriction (message-narrow-to-headers) - (setq resend-to-addresses (message-fetch-field "resent-to"))) + ;; XXX: We need to handle Resent-CC/Resent-BCC, too. + (setq resend-addresses (message-fetch-field "resent-to"))) ;; Change header-delimiter to be what sendmail expects. (goto-char (point-min)) (re-search-forward @@ -2015,7 +2318,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) @@ -2036,8 +2339,8 @@ the user from the mailer." ;; We must not do that for a resend ;; because we would find the original addresses. ;; For a resend, include the specific addresses. - (if resend-to-addresses - (list resend-to-addresses) + (if resend-addresses + (list resend-addresses) '("-t"))))) (when message-interactive (save-excursion @@ -2055,15 +2358,16 @@ the user from the mailer." "Pass the prepared message buffer to qmail-inject. Refer to the documentation for the variable `message-send-mail-function' to find out how to use this." - ;; replace the header delimiter with a blank line + ;; replace the header delimiter with a blank line. (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) (replace-match "\n") + (backward-char 1) (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 @@ -2111,13 +2415,40 @@ to find out how to use this." ;; Pass it on to mh. (mh-send-letter))) +(defun message-send-mail-with-smtp () + "Send off the prepared buffer with SMTP." + (require 'smtp) ; XXX + (let ((case-fold-search t) + recipients) + (save-restriction + (message-narrow-to-headers) + (setq recipients + ;; XXX: Should be replaced by better one. + (smtp-deduce-address-list (current-buffer) + (point-min) (point-max))) + ;; Remove BCC lines. + (message-remove-header "bcc")) + ;; replace the header delimiter with a blank line. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (backward-char 1) + (run-hooks 'message-send-mail-hook) + (if recipients + (let ((result (smtp-via-smtp user-mail-address + recipients + (current-buffer)))) + (unless (eq result t) + (error "Sending failed; " result))) + (error "Sending failed; no recipients")))) + (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) @@ -2132,19 +2463,13 @@ to find out how to use this." (run-hooks 'message-header-hook)) (message-cleanup-headers) (if (not (message-check-news-syntax)) - (progn - ;;(message "Posting not performed") - nil) + nil (unwind-protect (save-excursion (set-buffer tembuf) - (buffer-disable-undo (current-buffer)) + (buffer-disable-undo) (erase-buffer) - ;; Avoid copying text props. - (insert (format - "%s" (save-excursion - (set-buffer messbuf) - (buffer-string)))) + (insert-buffer message-encoding-buffer) ;; Remove some headers. (save-restriction (message-narrow-to-headers) @@ -2154,30 +2479,48 @@ to find out how to use this." ;; 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))) + (mime-edit-maybe-split-and-send + (function + (lambda () + (interactive) + (save-restriction + (std11-narrow-to-header mail-header-separator) + (goto-char (point-min)) + (when (re-search-forward "^Message-Id:" nil t) + (delete-region (match-end 0)(std11-field-end)) + (insert (concat " " (message-make-message-id))) + )) + (funcall message-send-news-function method) + ))) + (setq result (funcall message-send-news-function method))) (kill-buffer tembuf)) - (set-buffer messbuf) + (set-buffer message-edit-buffer) (if result (push 'news message-sent-message-via) (message "Couldn't send message via news: %s" (nnheader-get-report (car method))) nil)))) +;; 1997-09-29 by MORIOKA Tomohiko +(defun message-send-news-with-gnus (method) + (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) + (gnus-request-post method) + )) + ;;; ;;; Header generation & syntax checking. ;;; @@ -2211,7 +2554,9 @@ to find out how to use this." (message-narrow-to-headers) (message-check-news-header-syntax))) ;; Check the body. - (message-check-news-body-syntax))))) + (save-excursion + (set-buffer message-edit-buffer) + (message-check-news-body-syntax)))))) (defun message-check-news-header-syntax () (and @@ -2377,7 +2722,7 @@ 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 (nth 1 (std11-extract-address-components from)))) (cond ((not from) (message "There is no From line. Posting is denied.") @@ -2423,7 +2768,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)) @@ -2438,8 +2783,7 @@ 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. @@ -2472,18 +2816,18 @@ to find out how to use this." (defun message-do-fcc () "Process Fcc headers in the current buffer." (let ((case-fold-search t) - (buf (current-buffer)) + (coding-system-for-write 'raw-text) list file) (save-excursion (set-buffer (get-buffer-create " *message temp*")) - (buffer-disable-undo (current-buffer)) (erase-buffer) - (insert-buffer-substring buf) + (insert-buffer-substring message-encoding-buffer) (save-restriction (message-narrow-to-headers) (while (setq file (message-fetch-field "fcc")) (push file list) (message-remove-header "fcc" nil t))) + (run-hooks 'message-header-hook 'message-before-do-fcc-hook) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) (replace-match "" t t) @@ -2513,7 +2857,7 @@ to find out how to use this." "Append this article to Unix/babyl mail file.." (if (and (file-readable-p filename) (mail-file-babyl-p filename)) - (gnus-output-to-rmail filename t) + (rmail-output-to-rmail-file filename t) (gnus-output-to-mail filename t))) (defun message-cleanup-headers () @@ -2548,11 +2892,30 @@ 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 "")) + ;; We do all of this because XEmacs doesn't have the %z spec. + (concat (format-time-string + "%d %b %Y %H:%M:%S " (or now (current-time))) + (format "%s%02d%02d" + sign (/ zone 3600) + (% zone 3600))))) + +(defun message-make-followup-subject (subject) + "Make a followup Subject." + (cond + ((and (eq message-use-subject-re 'guess) + (string-match message-subject-encoded-re-regexp subject)) + subject) + (message-use-subject-re + (concat "Re: " (message-strip-subject-re subject))) + (t subject))) (defun message-make-message-id () "Make a unique Message-ID." @@ -2650,18 +3013,19 @@ 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)) + (let ((mid (mail-header-message-id message-reply-headers)) + (from (mail-header-from message-reply-headers)) (date (mail-header-date message-reply-headers))) - (when from - (let ((stop-pos - (string-match " *at \\| *@ \\| *(\\| *<" from))) - (concat (if (and stop-pos - (not (zerop stop-pos))) - (substring from 0 stop-pos) from) - "'s message of \"" - (if (or (not date) (string= date "")) - "(unknown date)" date) - "\"")))))) + (when mid + (concat mid + (when from + (let ((pair (std11-extract-address-components from))) + (concat "\n (" + (or (car pair) (cadr pair)) + "'s message of " + (if (or (not date) (string= date "")) + "(unknown date)" date) + ")")))))))) (defun message-make-distribution () "Make a Distribution header." @@ -2677,9 +3041,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." @@ -2765,7 +3127,7 @@ give as trustworthy answer as possible." "Return the pertinent part of `user-mail-address'." (when user-mail-address (if (string-match " " user-mail-address) - (nth 1 (mail-extract-address-components user-mail-address)) + (nth 1 (std11-extract-address-components user-mail-address)) user-mail-address))) (defun message-make-fqdn () @@ -2801,6 +3163,31 @@ give as trustworthy answer as possible." (or mail-host-address (message-make-fqdn))) +;; Dummy to avoid byte-compile warning. +(defvar mule-version) +(defvar emacs-beta-version) +(defvar xemacs-codename) +(defvar gnus-inviolable-extended-version) + +(defun message-make-user-agent () + "Return user-agent info if the value `message-user-agent' is non-nil. If the +\"User-Agent\" field has already exist, it's value will be added in the return +string." + (when message-user-agent + (save-excursion + (goto-char (point-min)) + (let ((case-fold-search t) + user-agent start p end) + (if (re-search-forward "^User-Agent:[\t ]*" nil t) + (progn + (setq start (match-beginning 0) + p (match-end 0) + end (std11-field-end) + user-agent (buffer-substring-no-properties p end)) + (delete-region start (1+ end)) + (concat message-user-agent " " user-agent)) + message-user-agent))))) + (defun message-generate-headers (headers) "Prepare article HEADERS. Headers already prepared in the buffer are not modified." @@ -2817,9 +3204,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-make-user-agent)) (Expires (message-make-expires)) (case-fold-search t) header value elem) @@ -2847,7 +3232,13 @@ 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 @@ -2889,7 +3280,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. @@ -2909,13 +3301,13 @@ Headers already prepared in the buffer are not modified." (not (message-check-element 'sender)) (not (string= (downcase - (cadr (mail-extract-address-components from))) + (cadr (std11-extract-address-components from))) (downcase secure-sender))) (or (null sender) (not (string= (downcase - (cadr (mail-extract-address-components sender))) + (cadr (std11-extract-address-components sender))) (downcase secure-sender))))) (goto-char (point-min)) ;; Rename any old Sender headers to Original-Sender. @@ -2963,14 +3355,12 @@ Headers already prepared in the buffer are not modified." (if (or (= (following-char) ?,) (eobp)) (when (not quoted) - (if (and (> (current-column) 78) - last) - (progn - (save-excursion - (goto-char last) - (insert "\n\t")) - (setq last (1+ (point)))) - (setq last (1+ (point))))) + (if last + (save-excursion + (goto-char last) + (looking-at "[ \t]*") + (replace-match "\n " t t))) + (setq last (1+ (point)))) (setq quoted (not quoted))) (unless (eobp) (forward-char 1)))) @@ -2978,10 +3368,17 @@ Headers already prepared in the buffer are not modified." (widen) (forward-line 1))) +(defun message-fill-references (header value) + (insert (capitalize (symbol-name header)) + ": " + (std11-fill-msg-id-list-string + (if (consp value) (car value) value)) + "\n")) + (defun message-fill-header (header value) (let ((begin (point)) - (fill-column 990) - (fill-prefix "\t")) + (fill-column 78) + (fill-prefix " ")) (insert (capitalize (symbol-name header)) ": " (if (consp value) (car value) value) @@ -3004,7 +3401,7 @@ Headers already prepared in the buffer are not modified." (let ((max 988) (cut 4) refs) - (nnheader-temp-write nil + (with-temp-buffer (insert references) (goto-char (point-min)) (while (re-search-forward "<[^>]+>" nil t) @@ -3049,7 +3446,7 @@ Headers already prepared in the buffer are not modified." (concat "*" type (if to (concat " to " - (or (car (mail-extract-address-components to)) + (or (car (std11-extract-address-components to)) to) "") "") (if (and group (not (string= group ""))) (concat " on " group) "") @@ -3060,7 +3457,24 @@ Headers already prepared in the buffer are not modified." (defun message-pop-to-buffer (name) "Pop to buffer NAME, and warn if it already exists and is modified." - (let ((buffer (get-buffer name))) + (let ((pop-up-frames pop-up-frames) + (special-display-buffer-names special-display-buffer-names) + (special-display-regexps special-display-regexps) + (same-window-buffer-names same-window-buffer-names) + (same-window-regexps same-window-regexps) + (buffer (get-buffer name)) + (cur (current-buffer))) + (if (or (and (featurep 'xemacs) + (not (eq 'tty (device-type)))) + window-system + (>= emacs-major-version 20)) + (when message-use-multi-frames + (setq pop-up-frames t + special-display-buffer-names nil + special-display-regexps nil + same-window-buffer-names nil + same-window-regexps nil)) + (setq pop-up-frames nil)) (if (and buffer (buffer-name buffer)) (progn @@ -3069,9 +3483,12 @@ 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) + (when pop-up-frames + (make-local-variable 'message-original-frame) + (setq message-original-frame (selected-frame))))) (defun message-do-send-housekeeping () "Kill old message buffers." @@ -3098,6 +3515,7 @@ Headers already prepared in the buffer are not modified." (nconc message-buffer-list (list (current-buffer)))))) (defvar mc-modes-alist) +(defvar message-get-reply-buffer-function nil) (defun message-setup (headers &optional replybuffer actions) (when (and (boundp 'mc-modes-alist) (not (assq 'message-mode mc-modes-alist))) @@ -3106,7 +3524,9 @@ Headers already prepared in the buffer are not modified." mc-modes-alist)) (when actions (setq message-send-actions actions)) - (setq message-reply-buffer replybuffer) + (setq message-reply-buffer + (or (cdr (assq 'reply-buffer message-parameter-alist)) + replybuffer)) (goto-char (point-min)) ;; Insert all the headers. (mail-header-format @@ -3185,7 +3605,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)) @@ -3204,14 +3625,14 @@ Headers already prepared in the buffer are not modified." (Subject . ,(or subject "")))))) ;;;###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) (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) + from date subject mct mft mrt + never-mct to cc + references message-id follow-to gnus-warning) (save-restriction (message-narrow-to-head) ;; Allow customizations to have their say. @@ -3226,74 +3647,121 @@ Headers already prepared in the buffer are not modified." (funcall message-wide-reply-to-function))))) ;; Find all relevant headers we need. (setq from (message-fetch-field "from") - date (message-fetch-field "date") + date (message-fetch-field "date" t) subject (or (message-fetch-field "subject") "none") + references (message-fetch-field "references") + message-id (message-fetch-field "message-id" t) to (message-fetch-field "to") cc (message-fetch-field "cc") - mct (message-fetch-field "mail-copies-to") - reply-to (unless ignore-reply-to (message-fetch-field "reply-to")) - references (message-fetch-field "references") - message-id (message-fetch-field "message-id" t)) + mct (when (and wide message-use-mail-copies-to) + (message-fetch-field "mail-copies-to")) + mft (when (and wide message-use-mail-followup-to) + (message-fetch-field "mail-followup-to")) + mrt (when message-use-mail-reply-to + (or (message-fetch-field "mail-reply-to") + (message-fetch-field "reply-to"))) + gnus-warning (message-fetch-field "gnus-warning")) + (when (and gnus-warning (string-match "<[^>]+>" gnus-warning)) + (setq message-id (match-string 0 gnus-warning))) ;; Remove any (buggy) Re:'s that are present and make a ;; proper one. - (when (string-match message-subject-re-regexp subject) - (setq subject (substring subject (match-end 0)))) - (setq subject (concat "Re: " subject)) - - (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)))))) + (setq subject (message-make-followup-subject subject)) (widen)) + ;; Handle special values of Mail-Copies-To. + (when mct + (cond + ((and (equal (downcase mct) "never") + (or (not (eq message-use-mail-copies-to 'ask)) + (message-y-or-n-p + (concat "Obey Mail-Copies-To: never? ") t "\ +You should normally obey the Mail-Copies-To: header. + + `Mail-Copies-To: never' +directs you not to send your response to the author."))) + (setq never-mct t) + (setq mct nil)) + ((and (equal (downcase mct) "always") + (or (not (eq message-use-mail-copies-to 'ask)) + (message-y-or-n-p + (concat "Obey Mail-Copies-To: always? ") t "\ +You should normally obey the Mail-Copies-To: header. + + `Mail-Copies-To: always' +sends a copy of your response to the author."))) + (setq mct (or mrt from))) + ((and (eq message-use-mail-copies-to 'ask) + (not + (message-y-or-n-p + (concat "Obey Mail-Copies-To: " mct " ? ") t "\ +You should normally obey the Mail-Copies-To: header. + + `Mail-Copies-To: " mct "' +sends a copy of your response to " (if (string-match "," mct) + "the specified addresses" + "that address") "."))) + (setq mct nil)) + )) + + (unless follow-to + (cond + (to-address (setq follow-to (list (cons 'To to-address)))) + ((not wide) (setq follow-to (list (cons 'To (or mrt from))))) + ;; Handle Mail-Followup-To. + ((and mft + (or (not (eq message-use-mail-followup-to 'ask)) + (message-y-or-n-p + (concat "Obey Mail-Followup-To: " mft "? ") t "\ +You should normally obey the Mail-Followup-To: header. + + `Mail-Followup-To: " mft "' +directs your response to " (if (string-match "," mft) + "the specified addresses" + "that address only") ". + +A typical situation where Mail-Followup-To is used is when the author thinks +that further discussion should take place only in " + (if (string-match "," mft) + "the specified mailing lists" + "that mailing list") "."))) + (setq follow-to (list (cons 'To mft))) + (when mct + (push (cons 'Cc mct) follow-to))) + (t + (let (ccalist) + (save-excursion + (message-set-work-buffer) + (unless never-mct + (insert (or mrt 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 mrt from ""))) + (setq ccalist + (mapcar + (lambda (addr) + (cons (mail-strip-quoted-names addr) addr)) + (message-tokenize-header (buffer-string)))) + (let ((s ccalist)) + (while s + (setq ccalist (delq (assoc (car (pop s)) s) ccalist))))) + (setq follow-to (list (cons 'To (cdr (pop ccalist))))) + (when ccalist + (let ((ccs (cons 'Cc (mapconcat + (lambda (addr) (cdr addr)) ccalist ", ")))) + (when (string-match "^ +" (cdr ccs)) + (setcdr ccs (substring (cdr ccs) (match-end 0)))) + (push ccs follow-to))))))) + (message-pop-to-buffer (message-buffer-name (if wide "wide reply" "reply") from (if wide to-address nil))) @@ -3306,49 +3774,52 @@ Headers already prepared in the buffer are not modified." ,@follow-to ,@(if (or references message-id) `((References . ,(concat (or references "") (and references " ") - (or message-id "")))) - nil)) + (or message-id "")))))) 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." + "Follow up to the message in the current buffer." (interactive) (let ((cur (current-buffer)) - from subject date reply-to mct - references message-id follow-to (inhibit-point-motion-hooks t) + from date subject mct mft mrt (message-this-is-news t) - followup-to distribution newsgroups gnus-warning posted-to) + followup-to distribution newsgroups posted-to + references message-id follow-to gnus-warning) (save-restriction - (narrow-to-region - (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - (1- (point)) - (point-max))) + (message-narrow-to-head) + ;; Allow customizations to have their say. + ;; This is a followup. (when (message-functionp message-followup-to-function) (setq follow-to (funcall message-followup-to-function))) + ;; Find all relevant headers we need. (setq from (message-fetch-field "from") - date (message-fetch-field "date") + date (message-fetch-field "date" t) subject (or (message-fetch-field "subject") "none") references (message-fetch-field "references") message-id (message-fetch-field "message-id" t) - followup-to (message-fetch-field "followup-to") + followup-to (when message-use-followup-to + (message-fetch-field "followup-to")) + distribution (message-fetch-field "distribution") newsgroups (message-fetch-field "newsgroups") posted-to (message-fetch-field "posted-to") - reply-to (message-fetch-field "reply-to") - distribution (message-fetch-field "distribution") - mct (message-fetch-field "mail-copies-to")) - (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) - (string-match "<[^>]+>" gnus-warning)) + mct (when message-use-mail-copies-to + (message-fetch-field "mail-copies-to")) + mft (when message-use-mail-followup-to + (message-fetch-field "mail-followup-to")) + mrt (when message-use-mail-reply-to + (or (message-fetch-field "mail-reply-to") + (message-fetch-field "reply-to"))) + gnus-warning (message-fetch-field "gnus-warning")) + (when (and gnus-warning (string-match "<[^>]+>" gnus-warning)) (setq message-id (match-string 0 gnus-warning))) ;; Remove bogus distribution. (when (and (stringp distribution) @@ -3357,40 +3828,68 @@ If TO-NEWSGROUPS, use that as the new Newsgroups line." (setq distribution nil)) ;; Remove any (buggy) Re:'s that are present and make a ;; proper one. - (when (string-match message-subject-re-regexp subject) - (setq subject (substring subject (match-end 0)))) - (setq subject (concat "Re: " subject)) + (setq subject (message-make-followup-subject subject)) (widen)) - (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) - - (message-setup - `((Subject . ,subject) - ,@(cond - (to-newsgroups - (list (cons 'Newsgroups to-newsgroups))) - (follow-to follow-to) - ((and followup-to message-use-followup-to) - (list - (cond - ((equal (downcase followup-to) "poster") - (if (or (eq message-use-followup-to 'use) - (message-y-or-n-p "Obey Followup-To: poster? " t "\ + ;; Handle special values of Mail-Copies-To. + (when mct + (cond + ((and (equal (downcase mct) "never") + (or (not (eq message-use-mail-copies-to 'ask)) + (message-y-or-n-p + (concat "Obey Mail-Copies-To: never? ") t "\ +You should normally obey the Mail-Copies-To: header. + + `Mail-Copies-To: never' +directs you not to send your response to the author."))) + (setq mct nil)) + ((and (equal (downcase mct) "always") + (or (not (eq message-use-mail-copies-to 'ask)) + (message-y-or-n-p + (concat "Obey Mail-Copies-To: always? ") t "\ +You should normally obey the Mail-Copies-To: header. + + `Mail-Copies-To: always' +sends a copy of your response to the author."))) + (setq mct (or mrt from))) + ((and (eq message-use-mail-copies-to 'ask) + (not + (message-y-or-n-p + (concat "Obey Mail-Copies-To: " mct " ? ") t "\ +You should normally obey the Mail-Copies-To: header. + + `Mail-Copies-To: " mct "' +sends a copy of your response to " (if (string-match "," mct) + "the specified addresses" + "that address") "."))) + (setq mct nil)) + )) + + (unless follow-to + (cond + (to-newsgroups (setq follow-to (list (cons 'Newsgroups to-newsgroups)))) + ;; Handle Followup-To. + (followup-to + (cond + ((equal (downcase followup-to) "poster") + (if (or (eq message-use-followup-to 'use) + (message-y-or-n-p "Obey Followup-To: poster? " t "\ You should normally obey the Followup-To: header. -`Followup-To: poster' sends your response via e-mail instead of news. + `Followup-To: poster' +sends your response via e-mail instead of news. -A typical situation where `Followup-To: poster' is used is when the poster +A typical situation where `Followup-To: poster' is used is when the author does not read the newsgroup, so he wouldn't see any replies sent to it.")) - (progn - (setq message-this-is-news nil) - (cons 'To (or reply-to from ""))) - (cons 'Newsgroups newsgroups))) - (t - (if (or (equal followup-to newsgroups) - (not (eq message-use-followup-to 'ask)) - (message-y-or-n-p - (concat "Obey Followup-To: " followup-to "? ") t "\ + (setq message-this-is-news nil + distribution nil + follow-to (list (cons 'To (or mrt from "")))) + (setq follow-to (list (cons 'Newsgroups newsgroups))))) + (t + (if (or (equal followup-to newsgroups) + (not (eq message-use-followup-to 'ask)) + (message-y-or-n-p + (concat "Obey Followup-To: " followup-to "? ") t "\ You should normally obey the Followup-To: header. `Followup-To: " followup-to "' @@ -3405,27 +3904,46 @@ be fragmented and very difficult to follow. Also, some source/announcement newsgroups are not indented for discussion; responses here are directed to other newsgroups.")) - (cons 'Newsgroups followup-to) - (cons 'Newsgroups newsgroups)))))) - (posted-to - `((Newsgroups . ,posted-to))) - (t - `((Newsgroups . ,newsgroups)))) - ,@(and distribution (list (cons 'Distribution distribution))) - ,@(if (or references message-id) - `((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") - (or reply-to from "") - mct))))) + (setq follow-to (list (cons 'Newsgroups followup-to))) + (setq follow-to (list (cons 'Newsgroups newsgroups))))))) + ;; Handle Mail-Followup-To, followup via e-mail. + ((and mft + (or (not (eq message-use-mail-followup-to 'ask)) + (message-y-or-n-p + (concat "Obey Mail-Followup-To: " mft "? ") t "\ +You should normally obey the Mail-Followup-To: header. + + `Mail-Followup-To: " mft "' +directs your response to " (if (string-match "," mft) + "the specified addresses" + "that address only") " instead of news. + +A typical situation where Mail-Followup-To is used is when the author thinks +that further discussion should take place only in " + (if (string-match "," mft) + "the specified mailing lists" + "that mailing list") "."))) + (setq message-this-is-news nil + distribution nil + follow-to (list (cons 'To mft)))) + (posted-to (setq follow-to (list (cons 'Newsgroups posted-to)))) + (t + (setq follow-to (list (cons 'Newsgroups newsgroups)))))) - cur) + (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) (setq message-reply-headers - (vector 0 subject from date message-id references 0 0 "")))) + (vector 0 subject from date message-id references 0 0 "")) + (message-setup + `((Subject . ,subject) + ,@follow-to + ,@(and mct (list (cons 'Cc mct))) + ,@(and distribution (list (cons 'Distribution distribution))) + ,@(if (or references message-id) + `((References . ,(concat (or references "") (and references " ") + (or message-id "")))))) + cur))) ;;;###autoload (defun message-cancel-news () @@ -3445,18 +3963,18 @@ responses here are directed to other 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 (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 + (unless (or (and sender + (string-equal + (downcase sender) + (downcase (message-make-sender)))) + (string-equal + (downcase (cadr (std11-extract-address-components + from))) + (downcase (cadr (std11-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)) (erase-buffer) (insert "Newsgroups: " newsgroups "\n" "From: " (message-make-from) "\n" @@ -3469,8 +3987,10 @@ responses here are directed to other newsgroups.")) message-cancel-message) (message "Canceling your article...") (if (let ((message-syntax-checks - 'dont-check-for-anything-just-trust-me)) - (funcall message-send-news-function)) + 'dont-check-for-anything-just-trust-me) + (message-encoding-buffer (current-buffer)) + (message-edit-buffer (current-buffer))) + (message-send-news)) (message "Canceling your article...done")) (kill-buffer buf))))) @@ -3480,13 +4000,18 @@ 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 (or (message-fetch-field "sender") - (cadr (mail-extract-address-components - (message-fetch-field "from"))))) - (downcase (message-make-sender))) + (unless (or (and sender + (string-equal + (downcase sender) + (downcase (message-make-sender)))) + (string-equal + (downcase (cadr (std11-extract-address-components from))) + (downcase (cadr (std11-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")) @@ -3522,18 +4047,81 @@ 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 (eword-decode-unstructured-field-body + (message-fetch-field "Subject")) "")) + (or (eword-decode-unstructured-field-body + (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) @@ -3581,9 +4169,11 @@ Optional NEWS will use news to forward instead of mail." 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))) + ;; avoid to turn-on-mime-edit + (let (message-setup-hook) + (message-setup `((To . ,address))) + ) ;; Insert our usual headers. (message-generate-headers '(From Date To)) (message-narrow-to-headers) @@ -3614,7 +4204,9 @@ 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-encoding-buffer (current-buffer)) + (message-edit-buffer (current-buffer))) + (message-send-mail)) (kill-buffer (current-buffer))) (message "Resending message to %s...done" address))) @@ -3631,7 +4223,7 @@ you." (insert-buffer-substring cur) (undo-boundary) (message-narrow-to-head) - (if (and (message-fetch-field "Mime-Version") + (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" @@ -3789,7 +4381,6 @@ Do a `tab-to-tab-stop' if not in those headers." (point)))) (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb)) (completions (all-completions string hashtb)) - (cur (current-buffer)) comp) (delete-region b (point)) (cond @@ -3808,7 +4399,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))) @@ -3870,6 +4461,56 @@ regexp varstr." (cdr local))))) locals))) + +;;; @ for MIME Edit mode +;;; + +(defun message-maybe-setup-default-charset () + (let ((charset + (and (boundp 'gnus-summary-buffer) + (buffer-live-p gnus-summary-buffer) + (save-excursion + (set-buffer gnus-summary-buffer) + default-mime-charset)))) + (if charset + (progn + (make-local-variable 'default-mime-charset) + (setq default-mime-charset charset) + )))) + +(defun message-maybe-encode () + (when message-mime-mode + (run-hooks 'mime-edit-translate-hook) + (if (catch 'mime-edit-error + (save-excursion + (mime-edit-translate-body) + )) + (error "Translation error!") + ) + (end-of-invisible) + (run-hooks 'mime-edit-exit-hook) + )) + +(defun message-mime-insert-article (&optional full-headers) + (interactive "P") + (let ((message-cite-function 'mime-edit-inserted-message-filter) + (message-reply-buffer (message-get-original-reply-buffer)) + (start (point))) + (message-yank-original nil) + (save-excursion + (narrow-to-region (goto-char start) + (if (search-forward "\n\n" nil t) + (1- (point)) + (point-max))) + (goto-char (point-min)) + (let ((message-included-forward-headers + (if full-headers "" message-included-forward-headers))) + (message-remove-header message-included-forward-headers t nil t)) + (widen)))) + +(set-alist 'mime-edit-message-inserter-alist + 'message-mode (function message-mime-insert-article)) + ;;; Miscellaneous functions ;; stolen (and renamed) from nnheader.el @@ -3885,6 +4526,39 @@ regexp varstr." (setq idx (1+ idx))) string)) +;;; +;;; MIME functions +;;; + +(defun message-encode-message-body () + "Examine the message body, encode it, and add the requisite headers." + (when (featurep 'mule) + (let (old-headers) + (save-excursion + (save-restriction + (message-narrow-to-headers-or-head) + (unless (setq old-headers (message-fetch-field "mime-version")) + (message-remove-header + "^Content-Transfer-Encoding:\\|^Content-Type:\\|^Mime-Version:" t)) + (goto-char (point-max)) + (widen) + (narrow-to-region (point) (point-max)) + (let* ((charset (mm-encode-body)) + (encoding (mm-body-encoding))) + (when (consp charset) + (error "Can't encode messages with multiple charsets (yet)")) + (widen) + (message-narrow-to-headers-or-head) + (goto-char (point-max)) + (setq charset (or charset + (mm-mule-charset-to-mime-charset 'ascii))) + ;; We don't insert MIME headers if they only say the default. + (when (and (not old-headers) + (not (and (eq charset 'us-ascii) + (eq encoding '7bit)))) + (mm-insert-rfc822-headers charset encoding)) + (mm-encode-body))))))) + (run-hooks 'message-load-hook) (provide 'message)