X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmessage.el;h=6c4d9309cad0421151c06a6fffe7749d410c7552;hp=d30b3f6d0fd9e2dffbb20df048a5bbe09739ab2f;hb=a2c927950fdddc21d7d245d01ed30463268f9234;hpb=7a8fe1a19ddb0e89f30d7cf657023ebf1bbe68ca diff --git a/lisp/message.el b/lisp/message.el index d30b3f6d0..6c4d9309c 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -31,9 +31,23 @@ (eval-when-compile (require 'cl)) -(require 'mail-header) +(require 'mailheader) +(require 'rmail) (require 'nnheader) (require 'timezone) +(require 'easymenu) +(if (string-match "XEmacs\\|Lucid" emacs-version) + (require 'mail-abbrevs) + (require 'mailabbrev)) + +(defvar message-directory "~/Mail/" + "*Directory from which all other mail file variables are derived.") + +(defvar message-max-buffers 10 + "*How many buffers to keep before starting to kill them off.") + +(defvar message-send-rename-function nil + "Function called to rename the buffer after sending it.") ;;;###autoload (defvar message-fcc-handler-function 'rmail-output @@ -49,7 +63,7 @@ mailbox format.") If this variable is nil, no such courtesy message will be added.") ;;;###autoload -(defvar message-ignored-bounced-headers "^\\(Received\\):" +(defvar message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):" "*Regexp that matches headers to be removed in resent bounced mail.") ;;;###autoload @@ -67,18 +81,20 @@ Otherwise, most addresses look like `angles', but they look like `parens' if `angles' would need quoting and `parens' would not.") ;;;###autoload -(defvar message-syntax-checks - '(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) - "In non-nil, message will attempt to run some checks on outgoing posts. -If this variable is t, message will check everything it can. If it is -a list, then those elements in that list will be checked.") +(defvar message-syntax-checks nil + "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.") ;;;###autoload (defvar message-required-news-headers - '(From Date Newsgroups Subject Message-ID + '(From Newsgroups Subject Date Message-ID (optional . Organization) Lines (optional . X-Newsreader)) "*Headers to be generated or prompted for when posting an article. @@ -89,7 +105,7 @@ header, remove it from this list.") ;;;###autoload (defvar message-required-mail-headers - '(From Date Subject (optional . In-Reply-To) Message-ID Lines + '(From Subject Date (optional . In-Reply-To) Message-ID Lines (optional . X-Mailer)) "*Headers to be generated or prompted for when mailing a message. RFC822 required that From, Date, To, Subject and Message-ID be @@ -109,23 +125,32 @@ included. Organization, Lines and X-Mailer are optional.") "*Regexp of headers to be removed unconditionally before mailing.") ;;;###autoload -(defvar message-ignored-supersedes-headers - "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|Return-Path:" +(defvar message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|Return-Path:\\|^Supersedes:" "*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.") ;;;###autoload (defvar message-signature-separator "^-- *$" - "Regexp matching signature separator.") + "Regexp matching the signature separator.") ;;;###autoload (defvar message-interactive nil "Non-nil means when sending a message wait for and display errors. nil means let mailer mail back a message to report errors.") -(defvar gnus-local-organization) ;;;###autoload +(defvar message-generate-new-buffers t + "*Non-nil means that a new message buffer will be created whenever `mail-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.") + +;;;###autoload +(defvar message-kill-buffer-on-exit nil + "*Non-nil means that the message buffer will be killed after sending a message.") + +(defvar gnus-local-organization) (defvar message-user-organization (or (and (boundp 'gnus-local-organization) gnus-local-organization) @@ -138,8 +163,8 @@ If t, use `message-user-organization-file'.") (defvar message-user-organization-file "/usr/lib/news/organization" "*Local news organization file.") -;;;###autoload -(defvar message-autosave-directory "~/Mail/drafts/" +(defvar message-autosave-directory "~/" + ; (concat (file-name-as-directory message-directory) "drafts/") "*Directory where message autosaves buffers. If nil, message won't autosave.") @@ -170,42 +195,52 @@ If nil, message won't autosave.") ;; Useful to set in site-init.el ;;;###autoload -(defvar message-send-mail-function 'message-send-mail +(defvar message-send-mail-function 'message-send-mail-with-sendmail "Function to call to send the current buffer as mail. The headers should be delimited by a line whose contents match the -variable `mail-header-separator'.") +variable `mail-header-separator'. + +Legal values include `message-send-mail-with-mh' and +`message-send-mail-with-sendmail', which is the default.") ;;;###autoload (defvar message-send-news-function 'message-send-news "Function to call to send the current buffer as news. The headers should be delimited by a line whose contents match the -variable `message-header-separator'.") +variable `mail-header-separator'.") ;;;###autoload (defvar message-reply-to-function nil - "Function that should return a list of headers.") + "Function that should return a list of headers. +This function should pick out addresses from the To, Cc, and From headers +and respond with new To and Cc headers.") ;;;###autoload (defvar message-wide-reply-to-function nil - "Function that should return a list of headers.") + "Function that should return a list of headers. +This function should pick out addresses from the To, Cc, and From headers +and respond with new To and Cc headers.") ;;;###autoload (defvar message-followup-to-function nil - "Function that should return a list of headers.") + "Function that should return a list of headers. +This function should pick out addresses from the To, Cc, and From headers +and respond with new To and Cc headers.") ;;;###autoload (defvar message-use-followup-to 'ask "*Specifies what to do with Followup-To header. -If nil, ignore the header. If it is t, use its value, but ignore -\"poster\". If it is the symbol `ask', query the user whether to -ignore the \"poster\" value. If it is the symbol `use', always use -the value.") +If nil, ignore the header. If it is t, use its value, but query before +using the \"poster\" value. If it is the symbol `ask', query the user +whether to ignore the \"poster\" value. If it is the symbol `use', +always use the value.") (defvar gnus-post-method) (defvar gnus-select-method) ;;;###autoload (defvar message-post-method - (cond ((boundp 'gnus-post-method) + (cond ((and (boundp 'gnus-post-method) + gnus-post-method) gnus-post-method) ((boundp 'gnus-select-method) gnus-select-method) @@ -216,28 +251,21 @@ the value.") (defvar message-generate-headers-first nil "*If non-nil, generate all possible headers before composing.") -;;;###autoload -(defvar message-header-separator "--text follows this line--" - "*Line used to separate headers from text in messages being composed.") - -;;;###autoload -(defvar message-alias-file nil - "*If non-nil, the name of a file to use instead of `/usr/lib/aliases'. -This file defines aliases to be expanded by the mailer; this is a different -feature from that of defining aliases in `.mailrc' to be expanded in Emacs. -This variable has no effect unless your system uses sendmail as its mailer.") - -;;;###autoload -(defvar message-personal-alias-file "~/.mailrc" - "*If non-nil, the name of the user's personal mail alias file. -This file typically should be in same format as the `.mailrc' file used by -the `Mail' or `mailx' program. -This file need not actually exist.") - (defvar message-setup-hook nil "Normal hook, run each time a new outgoing message is initialized. The function `message-setup' runs this hook.") +(defvar 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 +the signature is inserted.") + +(defvar message-mode-hook nil + "Hook run in message mode buffers.") + +(defvar message-header-hook nil + "Hook run in a message mode buffer narrowed to the headers.") + (defvar message-header-setup-hook nil "Hook called narrowed to the headers when setting up a message buffer.") @@ -245,17 +273,6 @@ The function `message-setup' runs this hook.") (defvar message-citation-line-function 'message-insert-citation-line "*Function called to insert the \"Whomever writes:\" line.") -(defvar message-aliases t - "Alist of mail address aliases. -If t, initialized from your mail aliases file. -\(The file's name is normally `~/.mailrc', but your MAILRC environment -variable can override that name.) -The alias definitions in the file have this form: - alias ALIAS MEANING") - -(defvar message-alias-modtime nil - "The modification time of your mail alias file when it was last examined.") - ;;;###autoload (defvar message-yank-prefix "> " "*Prefix inserted on the lines of yanked messages. @@ -278,23 +295,16 @@ point and mark around the citation text as modified.") (defvar message-abbrevs-loaded nil) -(autoload 'expand-mail-aliases "mailalias" - "Expand all mail aliases in suitable header fields found between BEG and END. -Suitable header fields are `To', `Cc' and `Bcc' and their `Resent-' variants. -Optional second arg EXCLUDE may be a regular expression defining text to be -removed from alias expansions." - nil) - ;;;###autoload (defvar message-signature t - "*String to be inserted at the and the the message buffer. + "*String to be inserted at the end of the message buffer. If t, the `message-signature-file' file will be inserted instead. If a function, the result from the function will be used instead. If a form, the result from the form will be used instead.") ;;;###autoload (defvar message-signature-file "~/.signature" - "*File containing the text inserted at end of mail buffer.") + "*File containing the text inserted at end of message. buffer.") (defvar message-distribution-function nil "*Function called to return a Distribution header.") @@ -314,6 +324,12 @@ If stringp, use this; if non-nil, use no host name (user name only).") (defvar message-checksum nil) (defvar message-send-actions nil "A list of actions to be performed upon successful sending of a message.") +(defvar message-exit-actions nil + "A list of actions to be performed upon exiting after sending a message.") +(defvar message-kill-actions nil + "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.") ;;;###autoload (defvar message-default-headers nil @@ -360,10 +376,14 @@ actually occur.") table) "Syntax table used while in Message mode.") +(defvar message-mode-abbrev-table text-mode-abbrev-table + "Abbrev table used in Message mode buffers. +Defaults to `text-mode-abbrev-table'.") + (defvar message-font-lock-keywords (let* ((cite-prefix "A-Za-z") (cite-suffix (concat cite-prefix "0-9_.@-"))) (list '("^To:" . font-lock-function-name-face) - '("^B?CC:\\|^Reply-To:" . font-lock-keyword-face) + '("^[GBF]?[Cc][Cc]:\\|^Reply-To:" . font-lock-keyword-face) '("^\\(Subject:\\)[ \t]*\\(.+\\)?" (1 font-lock-comment-face) (2 font-lock-type-face nil t)) (list (concat "^\\(" (regexp-quote mail-header-separator) "\\)$") @@ -391,10 +411,63 @@ The cdr of ech entry is a function for applying the face to a region.") (defvar message-sent-hook nil "Hook run after sending messages.") +;;; Internal variables. + +(defvar message-buffer-list nil) + +;;; Regexp matching the delimiter of messages in UNIX mail format +;;; (UNIX From lines), minus the initial ^. +(defvar message-unix-mail-delimiter + (let ((time-zone-regexp + (concat "\\([A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?" + "\\|[-+]?[0-9][0-9][0-9][0-9]" + "\\|" + "\\) *"))) + (concat + "From " + + ;; Username, perhaps with a quoted section that can contain spaces. + "\\(" + "[^ \n]*" + "\\(\\|\".*\"[^ \n]*\\)" + "\\|<[^<>\n]+>" + "\\) ?" + + ;; The time the message was sent. + "\\([^ \n]*\\) *" ; day of the week + "\\([^ ]*\\) *" ; month + "\\([0-9]*\\) *" ; day of month + "\\([0-9:]*\\) *" ; time of day + + ;; Perhaps a time zone, specified by an abbreviation, or by a + ;; numeric offset. + time-zone-regexp + + ;; The year. + " [0-9][0-9]\\([0-9]*\\) *" + + ;; On some systems the time zone can appear after the year, too. + time-zone-regexp + + ;; Old uucp cruft. + "\\(remote from .*\\)?" + + "\n"))) + +(defvar message-unsent-separator + (concat "^ *---+ +Unsent message follows +---+ *$\\|" + "^ *---+ +Returned message +---+ *$\\|" + "^Start of returned message$\\|" + "^ *---+ +Original message +---+ *$\\|" + "^ *--+ +begin message +--+ *$\\|" + "^ *---+ +Original message follows +---+ *$\\|" + "^|? *---+ +Message text follows: +---+ *|?$") + "A regexp that matches the separator before the text of a failed message.") + (defvar message-header-format-alist `((Newsgroups) - (To . message-fill-header) - (Cc . message-fill-header) + (To . message-fill-address) + (Cc . message-fill-address) (Subject) (In-Reply-To) (Fcc) @@ -410,6 +483,10 @@ The cdr of ech entry is a function for applying the face to a region.") (X-Newsreader)) "Alist used for formatting headers.") +(eval-and-compile + (autoload 'message-setup-toolbar "messagexmas") + (autoload 'mh-send-letter "mh-comp")) + ;;; @@ -440,17 +517,33 @@ The cdr of ech entry is a function for applying the face to a region.") (defun message-tokenize-header (header &optional separator) "Split HEADER into a list of header elements. \",\" is used as the separator." - (let* ((beg 0) - (separator (or separator ",")) - (regexp - (format "[ \t]*\\([^%s]+\\)?\\([%s]+\\|\\'\\)" separator separator)) - elems) - (while (and (string-match regexp header beg) - (< beg (length header))) - (when (match-beginning 1) - (push (match-string 1 header) elems)) - (setq beg (match-end 0))) - (nreverse elems))) + (let ((regexp (format "[%s]+" (or separator ","))) + (beg 1) + (first t) + quoted elems) + (save-excursion + (message-set-work-buffer) + (insert header) + (goto-char (point-min)) + (while (not (eobp)) + (if first + (setq first nil) + (forward-char 1)) + (cond ((and (> (point) beg) + (or (eobp) + (and (looking-at regexp) + (not quoted)))) + (push (buffer-substring beg (point)) elems) + (setq beg (match-end 0))) + ((= (following-char) ?\") + (setq quoted (not quoted))))) + (nreverse elems)))) + +(defun message-fetch-field (header) + "The same as `mail-fetch-field', only remove all newlines." + (let ((value (mail-fetch-field header))) + (when value + (nnheader-replace-chars-in-string value ?\n ? )))) (defun message-fetch-reply-field (header) "Fetch FIELD from the message we're replying to." @@ -458,7 +551,7 @@ The cdr of ech entry is a function for applying the face to a region.") (buffer-name message-reply-buffer)) (save-excursion (set-buffer message-reply-buffer) - (mail-fetch-field header)))) + (message-fetch-field header)))) (defun message-set-work-buffer () (if (get-buffer " *message work*") @@ -540,17 +633,59 @@ Return the number of headers removed." (save-excursion (save-restriction (message-narrow-to-headers) - (mail-fetch-field "newsgroups")))) + (message-fetch-field "newsgroups")))) (defun message-mail-p () "Say whether the current buffer contains a mail message." (save-excursion (save-restriction (message-narrow-to-headers) - (or (mail-fetch-field "to") - (mail-fetch-field "cc") - (mail-fetch-field "bcc"))))) + (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." + (beginning-of-line) + (or (eobp) (forward-char 1)) + (not (if (re-search-forward "^[^ \t]" nil t) + (beginning-of-line) + (goto-char (point-max))))) +(defun message-sort-headers-1 () + "Sort the buffer as headers using `message-rank' text props." + (goto-char (point-min)) + (sort-subr + nil 'message-next-header + (lambda () + (message-next-header) + (unless (bobp) + (forward-char -1))) + (lambda () + (or (get-text-property (point) 'message-rank) + 0)))) + +(defun message-sort-headers () + "Sort the headers of the current message according to `message-header-format-alist'." + (interactive) + (save-excursion + (save-restriction + (let ((max (1+ (length message-header-format-alist))) + rank) + (message-narrow-to-headers) + (while (re-search-forward "^[^ \n]+:" nil t) + (put-text-property + (match-beginning 0) (1+ (match-beginning 0)) + 'message-rank + (if (setq rank (length (memq (assq (intern (buffer-substring + (match-beginning 0) + (1- (match-end 0)))) + message-header-format-alist) + message-header-format-alist))) + (- max rank) + (1+ max))))) + (message-sort-headers-1)))) + ;;; @@ -567,13 +702,13 @@ Return the number of headers removed." (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to) (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc) - (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-fcc) + (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-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-o" 'message-goto-followup-to) + (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to) (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords) (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary) (define-key message-mode-map "\C-c\C-b" 'message-goto-body) @@ -586,16 +721,48 @@ Return the number of headers removed." (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\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) (define-key message-mode-map "\C-c\C-c" 'message-send-and-exit) - (define-key message-mode-map "\C-c\C-s" 'message-send)) - -(defun message-make-menu-bar () - (unless (boundp 'message-menu) - (easy-menu-define - message-menu message-mode-map "" - '("Message" - ["Fill Citation" message-fill-yanked-message t])))) + (define-key message-mode-map "\C-c\C-s" 'message-send) + (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer) + (define-key message-mode-map "\C-c\C-d" 'message-dont-send) + + (define-key message-mode-map "\t" 'message-tab)) + +(easy-menu-define message-mode-menu message-mode-map + "Message Menu." + '("Message" + "Go to Field:" + "----" + ["To" message-goto-to t] + ["Subject" message-goto-subject t] + ["Cc" message-goto-cc t] + ["Reply-to" message-goto-reply-to t] + ["Summary" message-goto-summary t] + ["Keywords" message-goto-keywords t] + ["Newsgroups" message-goto-newsgroups t] + ["Followup-To" message-goto-followup-to t] + ["Distribution" message-goto-distribution t] + ["Body" message-goto-body t] + ["Signature" message-goto-signature t] + "----" + "Miscellaneous Commands:" + "----" + ["Sort Headers" message-sort-headers t] + ["Yank Original" message-yank-original t] + ["Fill Yanked Message" message-fill-yanked-message t] + ["Insert Signature" message-insert-signature t] + ["Caesar (rot13) Message" message-caesar-buffer-body t] + ["Rename buffer" message-rename-buffer t] + ["Spellcheck" ispell-message t] + "----" + ["Send Message" message-send-and-exit t] + ["Abort Message" message-dont-send t])) + +(defvar facemenu-add-face-function) +(defvar facemenu-remove-face-function) ;;;###autoload (defun message-mode () @@ -622,9 +789,12 @@ C-c C-r message-ceasar-buffer-body (rot13 the message body)." (make-local-variable 'message-reply-buffer) (setq 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) (set-syntax-table message-mode-syntax-table) (use-local-map message-mode-map) - (setq local-abbrev-table text-mode-abbrev-table) + (setq local-abbrev-table message-mode-abbrev-table) (setq major-mode 'message-mode) (setq mode-name "Message") (setq buffer-offer-save t) @@ -644,9 +814,11 @@ C-c C-r message-ceasar-buffer-body (rot13 the message body)." (make-local-variable 'paragraph-start) (setq paragraph-start (concat (regexp-quote mail-header-separator) "$\\|[ \t]*[-_][-_][-_]+$\\|" + "-- $\\|" paragraph-start)) (setq paragraph-separate (concat (regexp-quote mail-header-separator) "$\\|[ \t]*[-_][-_][-_]+$\\|" + "-- $\\|" paragraph-separate)) (make-local-variable 'message-reply-headers) (setq message-reply-headers nil) @@ -657,6 +829,15 @@ C-c C-r message-ceasar-buffer-body (rot13 the message body)." (setq message-sent-message-via nil) (make-local-variable 'message-checksum) (setq message-checksum nil) + ;;(when (fboundp 'mail-hist-define-keys) + ;; (mail-hist-define-keys)) + (when (string-match "XEmacs\\|Lucid" emacs-version) + (message-setup-toolbar)) + (easy-menu-add message-mode-menu message-mode-map) + ;; Allow mail alias things. + (if (fboundp 'mail-abbrevs-setup) + (mail-abbrevs-setup) + (funcall (intern "mail-aliases-setup"))) (run-hooks 'text-mode-hook 'message-mode-hook)) @@ -725,6 +906,7 @@ C-c C-r message-ceasar-buffer-body (rot13 the message body)." (defun message-goto-body () "Move point to the beginning of 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)) @@ -740,14 +922,20 @@ C-c C-r message-ceasar-buffer-body (rot13 the message body)." (defun message-insert-to () "Insert a To header that points to the author of the article being replied to." (interactive) - (message-position-on-field "To") + (when (and (message-position-on-field "To") + (mail-fetch-field "to") + (not (string-match "\\` *\\'" (mail-fetch-field "to")))) + (insert ", ")) (insert (or (message-fetch-reply-field "reply-to") (message-fetch-reply-field "from") ""))) (defun message-insert-newsgroups () "Insert the Newsgroups header from the article being replied to." (interactive) - (message-position-on-field "Newsgroups") + (when (and (message-position-on-field "Newsgroups") + (mail-fetch-field "newsgroups") + (not (string-match "\\` *\\'" (mail-fetch-field "newsgroups")))) + (insert ",")) (insert (or (message-fetch-reply-field "newsgroups") ""))) @@ -756,9 +944,15 @@ C-c C-r message-ceasar-buffer-body (rot13 the message body)." (defun message-insert-signature (&optional force) "Insert a signature. See documentation for the `message-signature' variable." - (interactive (list t)) + (interactive (list 0)) (let* ((signature (cond ((and (null message-signature) + (eq force 0)) + (save-excursion + (goto-char (point-max)) + (not (re-search-backward + message-signature-separator nil t)))) + ((and (null message-signature) force) t) ((message-functionp message-signature) @@ -774,13 +968,11 @@ C-c C-r message-ceasar-buffer-body (rot13 the message body)." (file-exists-p message-signature-file)) signature)))) (when signature - ;; Remove blank lines at the end of the message. - (goto-char (point-max)) - (skip-chars-backward " \t\n") - (end-of-line) - (delete-region (point) (point-max)) ;; Insert the signature. - (insert "\n\n-- \n") + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (insert "\n-- \n") (if (eq signature t) (insert-file-contents message-signature-file) (insert signature)) @@ -840,6 +1032,32 @@ Mail and USENET news headers are not rotated." (narrow-to-region (point) (point-max))) (message-caesar-region (point-min) (point-max) rotnum)))) +(defun message-rename-buffer (&optional enter-string) + "Rename the *message* buffer to \"*message* RECIPIENT\". +If the function is run with a prefix, it will ask for a new buffer +name, rather than giving an automatic name." + (interactive "Pbuffer name: ") + (save-excursion + (save-restriction + (goto-char (point-min)) + (narrow-to-region (point) + (search-forward mail-header-separator nil 'end)) + (let* ((mail-to (if (message-news-p) (message-fetch-field "Newsgroups") + (message-fetch-field "To"))) + (mail-trimmed-to + (if (string-match "," mail-to) + (concat (substring mail-to 0 (match-beginning 0)) ", ...") + mail-to)) + (name-default (concat "*message* " mail-trimmed-to)) + (name (if enter-string + (read-string "New buffer name: " name-default) + name-default))) + (rename-buffer name t) + (setq buffer-auto-save-file-name + (format "%s%s" + (file-name-as-directory message-autosave-directory) + (file-name-nondirectory buffer-auto-save-file-name))))))) + (defun message-fill-yanked-message (&optional justifyp) "Fill the paragraphs of a message yanked into this one. Numeric argument means justify as well." @@ -847,10 +1065,8 @@ Numeric argument means justify as well." (save-excursion (goto-char (point-min)) (search-forward (concat "\n" mail-header-separator "\n") nil t) - (fill-individual-paragraphs (point) - (point-max) - justifyp - t))) + (let ((fill-prefix message-yank-prefix)) + (fill-individual-paragraphs (point) (point-max) justifyp t)))) (defun message-indent-citation () "Modify text just inserted from a message to be cited. @@ -885,6 +1101,8 @@ Puts point before the text and mark after. Normally indents each nonblank line ARG spaces (default 3). However, if `message-yank-prefix' is non-nil, insert that prefix on each line. +This function uses `message-cite-function' to do the actual citing. + Just \\[universal-argument] as argument means don't indent, insert no prefix, and don't delete any headers." (interactive "P") @@ -894,11 +1112,11 @@ prefix, and don't delete any headers." (delete-windows-on message-reply-buffer t) (insert-buffer message-reply-buffer) (funcall message-cite-function) - (exchange-point-and-mark) + (message-exchange-point-and-mark) (unless (bolp) (insert ?\n)) (unless modified - (setq message-checksum (message-checksum)))))) + (setq message-checksum (cons (message-checksum) (buffer-size))))))) (defun message-cite-original () (let ((start (point)) @@ -979,17 +1197,29 @@ The text will also be indented the normal way." (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))) + (let ((buf (current-buffer)) + (actions message-exit-actions)) (when (and (message-send arg) (buffer-name buf)) - (bury-buffer buf) - (when (eq buf (current-buffer)) - (message-bury buf))))) + (if message-kill-buffer-on-exit + (kill-buffer buf) + (bury-buffer buf) + (when (eq buf (current-buffer)) + (message-bury buf))) + (message-do-actions actions)))) (defun message-dont-send () "Don't send the message you have been editing." (interactive) - (message-bury (current-buffer))) + (message-bury (current-buffer)) + (message-do-actions message-postpone-actions)) + +(defun message-kill-buffer () + "Kill the current buffer." + (interactive) + (let ((actions message-kill-actions)) + (kill-buffer (current-buffer)) + (message-do-actions actions))) (defun message-bury (buffer) "Bury this mail buffer." @@ -1017,6 +1247,9 @@ the user from the mailer." (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...") (when (and (or (not (message-news-p)) @@ -1028,46 +1261,74 @@ the user from the mailer." (and (or (not (memq 'mail message-sent-message-via)) (y-or-n-p "Already sent message via mail; resend? ")) - (funcall message-send-mail-function arg)))) + (message-send-mail arg)))) (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") ;; If buffer has no file, mark it as unmodified and delete autosave. (unless buffer-file-name (set-buffer-modified-p nil) (delete-auto-save-file-if-necessary t)) - ;; Now perform actions on successful sending. - (let ((actions message-send-actions)) - (while actions - (condition-case nil - (apply (caar actions) (cdar actions)) - (error)) - (pop actions))) + ;; Delete other mail buffers and stuff. + (message-do-send-housekeeping) + (message-do-actions message-send-actions) ;; Return success. t))) +(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"))) + +(defun message-add-action (action &rest types) + "Add ACTION to be performed when doing an exit of type TYPES." + (let (var) + (while types + (set (setq var (intern (format "message-%s-actions" (pop types)))) + (nconc (symbol-value var) (list action)))))) + +(defun message-do-actions (actions) + "Perform all actions in ACTIONS." + ;; Now perform actions on successful sending. + (while actions + (condition-case nil + (cond + ;; A simple function. + ((message-functionp (car actions)) + (funcall (car actions))) + ;; Something to be evaled. + (t + (eval (car actions)))) + (error)) + (pop actions))) + (defun message-send-mail (&optional arg) (require 'mail-utils) - (let ((errbuf (if message-interactive - (generate-new-buffer " sendmail errors") - 0)) - (tembuf (generate-new-buffer " message temp")) + (let ((tembuf (generate-new-buffer " message temp")) (case-fold-search nil) (news (message-news-p)) - (resend-to-addresses (mail-fetch-field "resent-to")) - delimline (mailbuf (current-buffer))) (save-restriction (message-narrow-to-headers) ;; Insert some headers. - (message-generate-headers message-required-mail-headers) + (let ((message-deletable-headers + (if news nil message-deletable-headers))) + (message-generate-headers message-required-mail-headers)) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) (unwind-protect (save-excursion (set-buffer tembuf) (erase-buffer) - (insert-buffer-substring mailbuf) + ;; Avoid copying text props. + (insert (format + "%s" (save-excursion + (set-buffer mailbuf) + (buffer-string)))) ;; Remove some headers. (save-restriction (message-narrow-to-headers) @@ -1078,83 +1339,116 @@ the user from the mailer." (or (= (preceding-char) ?\n) (insert ?\n)) (when (and news - (or (mail-fetch-field "cc") - (mail-fetch-field "to"))) + (or (message-fetch-field "cc") + (message-fetch-field "to"))) (message-insert-courtesy-copy)) - (let ((case-fold-search t)) - ;; Change header-delimiter to be what sendmail expects. - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (replace-match "\n") - (backward-char 1) - (setq delimline (point-marker)) - ;; Insert an extra newline if we need it to work around - ;; Sun's bug that swallows newlines. - (goto-char (1+ delimline)) - (when (eval message-mailer-swallows-blank-line) - (newline)) - (when message-interactive - (save-excursion - (set-buffer errbuf) - (erase-buffer)))) - (let ((default-directory "/")) - (apply 'call-process-region - (append (list (point-min) (point-max) - (if (boundp 'sendmail-program) - sendmail-program - "/usr/lib/sendmail") - nil errbuf nil "-oi") - ;; Always specify who from, - ;; since some systems have broken sendmails. - (list "-f" (user-login-name)) - (and message-alias-file - (list (concat "-oA" message-alias-file))) - ;; These mean "report errors by mail" - ;; and "deliver in background". - (if (null message-interactive) '("-oem" "-odb")) - ;; Get the addresses from the message - ;; unless this is a resend. - ;; We must not do that for a resend - ;; because we would find the original addresses. - ;; For a resend, include the specific addresses. - (or resend-to-addresses - '("-t"))))) - (when message-interactive - (save-excursion - (set-buffer errbuf) - (goto-char (point-min)) - (while (re-search-forward "\n\n* *" nil t) - (replace-match "; ")) - (if (not (zerop (buffer-size))) - (error "Sending...failed to %s" - (buffer-substring (point-min) (point-max))))))) - (kill-buffer tembuf) - (when (bufferp errbuf) - (kill-buffer errbuf))) + (funcall message-send-mail-function)) + (kill-buffer tembuf)) (set-buffer mailbuf) (push 'mail message-sent-message-via))) +(defun message-send-mail-with-sendmail () + "Send off the prepared buffer with sendmail." + (let ((errbuf (if message-interactive + (generate-new-buffer " sendmail errors") + 0)) + resend-to-addresses delimline) + (let ((case-fold-search t)) + (save-restriction + (message-narrow-to-headers) + (setq resend-to-addresses (message-fetch-field "resent-to"))) + ;; Change header-delimiter to be what sendmail expects. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (backward-char 1) + (setq delimline (point-marker)) + ;; Insert an extra newline if we need it to work around + ;; Sun's bug that swallows newlines. + (goto-char (1+ delimline)) + (when (eval message-mailer-swallows-blank-line) + (newline)) + (when message-interactive + (save-excursion + (set-buffer errbuf) + (erase-buffer)))) + (let ((default-directory "/")) + (apply 'call-process-region + (append (list (point-min) (point-max) + (if (boundp 'sendmail-program) + sendmail-program + "/usr/lib/sendmail") + nil errbuf nil "-oi") + ;; Always specify who from, + ;; since some systems have broken sendmails. + (list "-f" (user-login-name)) + ;; These mean "report errors by mail" + ;; and "deliver in background". + (if (null message-interactive) '("-oem" "-odb")) + ;; Get the addresses from the message + ;; unless this is a resend. + ;; We must not do that for a resend + ;; because we would find the original addresses. + ;; For a resend, include the specific addresses. + (if resend-to-addresses + (list resend-to-addresses) + '("-t"))))) + (when message-interactive + (save-excursion + (set-buffer errbuf) + (goto-char (point-min)) + (while (re-search-forward "\n\n* *" nil t) + (replace-match "; ")) + (if (not (zerop (buffer-size))) + (error "Sending...failed to %s" + (buffer-substring (point-min) (point-max))))) + (when (bufferp errbuf) + (kill-buffer errbuf))))) + +(defun message-send-mail-with-mh () + "Send the prepared message buffer with mh." + (let ((mh-previous-window-config nil) + (name (make-temp-name + (concat (file-name-as-directory message-autosave-directory) + "msg.")))) + (setq buffer-file-name name) + (mh-send-letter) + (condition-case () + (delete-file name) + (error nil)))) + (defun message-send-news (&optional arg) (let ((tembuf (generate-new-buffer " *message temp*")) (case-fold-search nil) (method (if (message-functionp message-post-method) (funcall message-post-method arg) message-post-method)) - (messbuf (current-buffer))) + (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) (when (message-check-news-syntax) (unwind-protect (save-excursion (set-buffer tembuf) (buffer-disable-undo (current-buffer)) (erase-buffer) - (insert-buffer-substring messbuf) + ;; Avoid copying text props. + (insert (format + "%s" (save-excursion + (set-buffer messbuf) + (buffer-string)))) ;; Remove some headers. (save-restriction (message-narrow-to-headers) @@ -1174,11 +1468,15 @@ the user from the mailer." (require (car method)) (funcall (intern (format "%s-open-server" (car method))) (cadr method) (cddr method)) - (funcall (intern (format "%s-request-post" - (car method))))) + (setq result + (funcall (intern (format "%s-request-post" (car method)))))) (kill-buffer tembuf)) (set-buffer messbuf) - (push 'news message-sent-message-via)))) + (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. @@ -1186,227 +1484,307 @@ the user from the mailer." (defun message-check-news-syntax () "Check the syntax of the message." - (or - (not message-syntax-checks) - (and - ;; We narrow to the headers and check them first. - (save-excursion - (save-restriction - (message-narrow-to-headers) - (and - ;; Check for commands in Subject. - (or - (message-check-element 'subject-cmsg) - (save-excursion - (if (string-match "^cmsg " (mail-fetch-field "subject")) - (y-or-n-p - "The control code \"cmsg \" is in the subject. Really post? ") - t))) - ;; Check for multiple identical headers. - (or (message-check-element 'multiple-headers) - (save-excursion - (let (found) - (while (and (not found) - (re-search-forward "^[^ \t:]+: " nil t)) - (save-excursion - (or (re-search-forward - (concat "^" (setq found - (buffer-substring - (match-beginning 0) - (- (match-end 0) 2)))) - nil t) - (setq found nil)))) - (if found - (y-or-n-p - (format "Multiple %s headers. Really post? " found)) - t)))) - ;; Check for Version and Sendsys. - (or (message-check-element 'sendsys) - (save-excursion - (if (re-search-forward "^Sendsys:\\|^Version:" nil t) - (y-or-n-p - (format "The article contains a %s command. Really post? " - (buffer-substring (match-beginning 0) - (1- (match-end 0))))) - t))) - ;; See whether we can shorten Followup-To. - (or (message-check-element 'shorten-followup-to) - (let ((newsgroups (mail-fetch-field "newsgroups")) - (followup-to (mail-fetch-field "followup-to")) - to) - (when (and newsgroups (string-match "," newsgroups) - (not followup-to) - (not - (zerop - (length - (setq to (completing-read - "Followups to: (default all groups) " - (mapcar (lambda (g) (list g)) - (cons "poster" - (message-tokenize-header - newsgroups))))))))) - (goto-char (point-min)) - (insert "Followup-To: " to "\n")))) - - ;; Check for Approved. - (or (message-check-element 'approved) - (save-excursion - (if (re-search-forward "^Approved:" nil t) - (y-or-n-p - "The article contains an Approved header. Really post? ") - t))) - ;; Check the Message-Id header. - (or (message-check-element 'message-id) - (save-excursion - (let* ((case-fold-search t) - (message-id (mail-fetch-field "message-id"))) - (or (not message-id) - (and (string-match "@" message-id) - (string-match "@[^\\.]*\\." message-id)) - (y-or-n-p - (format - "The Message-ID looks strange: \"%s\". Really post? " - message-id)))))) - ;; Check the Subject header. - (or - (message-check-element 'subject) - (save-excursion - (let* ((case-fold-search t) - (subject (mail-fetch-field "subject"))) - (or - (and subject - (not (string-match "\\`[ \t]*\\'" subject))) - (progn - (message - "The subject field is empty or missing. Posting is denied.") - nil))))) - ;; Check the From header. - (or (message-check-element 'from) - (save-excursion - (let* ((case-fold-search t) - (from (mail-fetch-field "from"))) - (cond - ((not from) - (message "There is no From line. Posting is denied.") - nil) - ((not (string-match "@[^\\.]*\\." from)) - (message - "Denied posting -- the From looks strange: \"%s\"." from) - nil) - ((string-match "@[^@]*@" from) - (message - "Denied posting -- two \"@\"'s in the From header: %s." - from) - nil) - ((string-match "(.*).*(.*)" from) - (message - "Denied posting -- the From header looks strange: \"%s\"." - from) - nil) - (t t)))))))) - ;; Check for long lines. - (or (message-check-element 'long-lines) - (save-excursion - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$")) - (while (and - (progn - (end-of-line) - (< (current-column) 80)) - (zerop (forward-line 1)))) - (or (bolp) - (eobp) - (y-or-n-p - "You have lines longer than 79 characters. Really post? ")))) - ;; Check whether the article is empty. - (or (message-check-element 'empty) - (save-excursion - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$")) - (forward-line 1) - (or (re-search-forward "[^ \n\t]" nil t) - (y-or-n-p "Empty article. Really post?")))) - ;; Check for control characters. - (or (message-check-element 'control-chars) - (save-excursion - (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t) - (y-or-n-p - "The article contains control characters. Really post? ") - t))) - ;; Check excessive size. - (or (message-check-element 'size) - (if (> (buffer-size) 60000) + (and + ;; We narrow to the headers and check them first. + (save-excursion + (save-restriction + (message-narrow-to-headers) + (and + ;; Check for commands in Subject. + (or + (message-check-element 'subject-cmsg) + (save-excursion + (if (string-match "^cmsg " (message-fetch-field "subject")) + (y-or-n-p + "The control code \"cmsg \" is in the subject. Really post? ") + t))) + ;; Check for multiple identical headers. + (or (message-check-element 'multiple-headers) + (save-excursion + (let (found) + (while (and (not found) + (re-search-forward "^[^ \t:]+: " nil t)) + (save-excursion + (or (re-search-forward + (concat "^" (setq found + (buffer-substring + (match-beginning 0) + (- (match-end 0) 2)))) + nil t) + (setq found nil)))) + (if found + (y-or-n-p + (format "Multiple %s headers. Really post? " found)) + t)))) + ;; Check for Version and Sendsys. + (or (message-check-element 'sendsys) + (save-excursion + (if (re-search-forward "^Sendsys:\\|^Version:" nil t) + (y-or-n-p + (format "The article contains a %s command. Really post? " + (buffer-substring (match-beginning 0) + (1- (match-end 0))))) + t))) + ;; See whether we can shorten Followup-To. + (or (message-check-element 'shorten-followup-to) + (let ((newsgroups (message-fetch-field "newsgroups")) + (followup-to (message-fetch-field "followup-to")) + to) + (when (and newsgroups (string-match "," newsgroups) + (not followup-to) + (not + (zerop + (length + (setq to (completing-read + "Followups to: (default all groups) " + (mapcar (lambda (g) (list g)) + (cons "poster" + (message-tokenize-header + newsgroups))))))))) + (goto-char (point-min)) + (insert "Followup-To: " to "\n")) + t)) + ;; Check "Shoot me". + (or (message-check-element 'shoot) + (save-excursion + (if (re-search-forward + "Message-ID.*.i-have-a-misconfigured-system-so-shoot-me" + nil t) + (y-or-n-p + "You appear to have a misconfigured system. Really post? ") + t))) + ;; Check for Approved. + (or (message-check-element 'approved) + (save-excursion + (if (re-search-forward "^Approved:" nil t) + (y-or-n-p + "The article contains an Approved header. Really post? ") + t))) + ;; Check the Message-Id header. + (or (message-check-element 'message-id) + (save-excursion + (let* ((case-fold-search t) + (message-id (message-fetch-field "message-id"))) + (or (not message-id) + (and (string-match "@" message-id) + (string-match "@[^\\.]*\\." message-id)) + (y-or-n-p + (format + "The Message-ID looks strange: \"%s\". Really post? " + message-id)))))) + ;; Check the Subject header. + (or + (message-check-element 'subject) + (save-excursion + (let* ((case-fold-search t) + (subject (message-fetch-field "subject"))) + (or + (and subject + (not (string-match "\\`[ \t]*\\'" subject))) + (progn + (message + "The subject field is empty or missing. Posting is denied.") + nil))))) + ;; Check the Newsgroups & Followup-To headers. + (or + (message-check-element 'existing-newsgroups) + (let* ((case-fold-search t) + (newsgroups (message-fetch-field "newsgroups")) + (followup-to (message-fetch-field "followup-to")) + (groups (message-tokenize-header + (if followup-to + (concat newsgroups "," followup-to) + newsgroups))) + (hashtb (and (boundp 'gnus-active-hashtb) + gnus-active-hashtb)) + errors) + (if (not hashtb) + t + (while groups + (when (and (not (boundp (intern (car groups) hashtb))) + (not (equal (car groups) "poster"))) + (push (car groups) errors)) + (pop groups)) + (if (not errors) + t + (y-or-n-p + (format + "Really post to %s unknown group%s: %s " + (if (= (length errors) 1) "this" "these") + (if (= (length errors) 1) "" "s") + (mapconcat 'identity errors ", "))))))) + ;; Check the Newsgroups & Followup-To headers for syntax errors. + (or + (message-check-element 'valid-newsgroups) + (let ((case-fold-search t) + (headers '("Newsgroups" "Followup-To")) + header error) + (while (and headers (not error)) + (when (setq header (mail-fetch-field (car headers))) + (if (or + (not + (string-match + "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-.a-zA-Z0-9]+\\)*\\'" + header)) + (memq + nil (mapcar + (lambda (g) + (not (string-match "\\.\\'\\|\\.\\." g))) + (message-tokenize-header header ",")))) + (setq error t))) + (unless error + (pop headers))) + (if (not error) + t + (y-or-n-p + (format "The %s header looks odd: \"%s\". Really post? " + (car headers) header))))) + ;; Check the From header. + (or + (save-excursion + (let* ((case-fold-search t) + (from (message-fetch-field "from"))) + (cond + ((not from) + (message "There is no From line. Posting is denied.") + nil) + ((not (string-match "@[^\\.]*\\." from)) + (message + "Denied posting -- the From looks strange: \"%s\"." from) + nil) + ((string-match "@[^@]*@" from) + (message + "Denied posting -- two \"@\"'s in the From header: %s." from) + nil) + ((string-match "(.*).*(.*)" from) + (message + "Denied posting -- the From header looks strange: \"%s\"." + from) + nil) + (t t)))))))) + ;; Check for long lines. + (or (message-check-element 'long-lines) + (save-excursion + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$")) + (while (and + (progn + (end-of-line) + (< (current-column) 80)) + (zerop (forward-line 1)))) + (or (bolp) + (eobp) + (y-or-n-p + "You have lines longer than 79 characters. Really post? ")))) + ;; Check whether the article is empty. + (or (message-check-element 'empty) + (save-excursion + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$")) + (forward-line 1) + (let ((b (point))) + (goto-char (point-max)) + (re-search-backward message-signature-separator nil t) + (beginning-of-line) + (or (re-search-backward "[^ \n\t]" b t) + (y-or-n-p "Empty article. Really post? "))))) + ;; Check for control characters. + (or (message-check-element 'control-chars) + (save-excursion + (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t) + (y-or-n-p + "The article contains control characters. Really post? ") + t))) + ;; Check excessive size. + (or (message-check-element 'size) + (if (> (buffer-size) 60000) + (y-or-n-p + (format "The article is %d octets long. Really post? " + (buffer-size))) + t)) + ;; Check whether any new text has been added. + (or (message-check-element 'new-text) + (not message-checksum) + (not (and (eq (message-checksum) (car message-checksum)) + (eq (buffer-size) (cdr message-checksum)))) + (y-or-n-p + "It looks like no new text has been added. Really post? ")) + ;; Check the length of the signature. + (or + (message-check-element 'signature) + (progn + (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 "The article is %d octets long. Really post? " - (buffer-size))) - t)) - ;; Check whether any new text has been added. - (or (message-check-element 'new-text) - (not 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. - (or (message-check-element 'signature) - (progn - (goto-char (point-max)) - (if (not (re-search-backward "^-- $" 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? " - (count-lines (point) (point-max)))) - t))))))) - -;; Returns non-nil if this type is not to be checked. + (format + "Your .sig is %d lines; it should be max 4. Really post? " + (count-lines (point) (point-max)))) + t)))))) + (defun message-check-element (type) - (not - (or (not message-syntax-checks) - (if (listp message-syntax-checks) - (memq type message-syntax-checks) - t)))) + "Returns non-nil if this type is not to be checked." + (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me) + t + (let ((able (assq type message-syntax-checks))) + (and (consp able) + (eq (cdr able) 'disabled))))) (defun message-checksum () "Return a \"checksum\" for the current buffer." (let ((sum 0)) (save-excursion + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$")) (while (not (eobp)) - (setq sum (logxor sum (following-char))) + (when (not (looking-at "[ \t\n]")) + (setq sum (logxor (ash sum 1) (following-char)))) (forward-char 1))) sum)) (defun message-do-fcc () "Process Fcc headers in the current buffer." (let ((case-fold-search t) + (buf (current-buffer)) list file) (save-excursion + (set-buffer (get-buffer-create " *message temp*")) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (insert-buffer-substring buf) (save-restriction (message-narrow-to-headers) - (while (setq file (mail-fetch-field "fcc")) + (while (setq file (message-fetch-field "fcc")) (push file list) - (message-remove-header "fcc" nil t)) - ;; Process FCC operations. - (widen) - (while list - (setq file (pop list)) - (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file) - ;; Pipe the article to the program in question. - (call-process-region (point-min) (point-max) shell-file-name - nil nil nil "-c" (match-string 1 file)) - ;; Save the article. - (setq file (expand-file-name file)) - (unless (file-exists-p (file-name-directory file)) - (make-directory (file-name-directory file) t)) - (if (and message-fcc-handler-function - (not (eq message-fcc-handler-function 'rmail-output))) - (funcall message-fcc-handler-function file) - (if (and (file-readable-p file) (mail-file-babyl-p file)) - (rmail-output file 1) - (let ((mail-use-rfc822 t)) - (rmail-output file 1 t t)))))))))) + (message-remove-header "fcc" nil t))) + (goto-char (point-min)) + (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) + (replace-match "" t t) + ;; Process FCC operations. + (while list + (setq file (pop list)) + (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file) + ;; Pipe the article to the program in question. + (call-process-region (point-min) (point-max) shell-file-name + nil nil nil shell-command-switch + (match-string 1 file)) + ;; Save the article. + (setq file (expand-file-name file)) + (unless (file-exists-p (file-name-directory file)) + (make-directory (file-name-directory file) t)) + (if (and message-fcc-handler-function + (not (eq message-fcc-handler-function 'rmail-output))) + (funcall message-fcc-handler-function file) + (if (and (file-readable-p file) (mail-file-babyl-p file)) + (rmail-output file 1) + (let ((mail-use-rfc822 t)) + (rmail-output file 1 t t)))))) + (kill-buffer (current-buffer))))) (defun message-cleanup-headers () "Do various automatic cleanups of the headers." @@ -1448,7 +1826,7 @@ the user from the mailer." (defun message-make-message-id () "Make a unique Message-ID." (concat "<" (message-unique-id) - (let ((psubject (save-excursion (mail-fetch-field "subject")))) + (let ((psubject (save-excursion (message-fetch-field "subject")))) (if (and message-reply-headers (mail-header-references message-reply-headers) (mail-header-subject message-reply-headers) @@ -1459,7 +1837,7 @@ the user from the mailer." (mail-header-subject message-reply-headers)) (message-strip-subject-re psubject)))) "_-_" "")) - "@" (message-make-fqdm) ">")) + "@" (message-make-fqdn) ">")) (defvar message-unique-id-char nil) @@ -1509,14 +1887,14 @@ the user from the mailer." message-user-organization))))) (save-excursion (message-set-work-buffer) - (cond ((stringp message-user-organization) - (insert message-user-organization)) - ((and (eq t message-user-organization) + (cond ((stringp organization) + (insert organization)) + ((and (eq t organization) message-user-organization-file (file-exists-p message-user-organization-file)) (insert-file-contents message-user-organization-file))) (goto-char (point-min)) - (when (re-search-forward "[ \t\n]*" nil t) + (while (re-search-forward "[\t\n]+" nil t) (replace-match "" t t)) (unless (zerop (buffer-size)) (buffer-string))))) @@ -1576,7 +1954,10 @@ the user from the mailer." (defun message-make-from () "Make a From header." (let* ((login (message-make-address)) - (fullname (user-full-name))) + (fullname + (or (and (boundp 'user-full-name) + user-full-name) + (user-full-name)))) (when (string= fullname "&") (setq fullname (user-login-name))) (save-excursion @@ -1641,39 +2022,40 @@ give as trustworthy answer as possible." (defun message-user-mail-address () "Return the pertinent part of `user-mail-address'." - (when (string-match - "\\(\\`\\|[ \t]\\)\\([^ \t@]+@[^ \t]+\\)\\(\\'\\|[ \t]\\)" - user-mail-address) - (match-string 2 user-mail-address))) + (when user-mail-address + (nth 1 (mail-extract-address-components user-mail-address)))) -(defun message-make-fqdm () +(defun message-make-fqdn () "Return user's fully qualified domain name." - (let ((system-name (system-name))) + (let ((system-name (system-name)) + (user-mail (message-user-mail-address))) (cond ((string-match "[^.]\\.[^.]" system-name) ;; `system-name' returned the right result. system-name) - ;; We try `user-mail-address' as a backup. - ((string-match "@\\([^\\s-]+\\)\\(\\'\\|\\W\\)" user-mail-address) - (match-string 1 user-mail-address)) ;; Try `mail-host-address'. ((and (boundp 'mail-host-address) - mail-host-address) + (stringp mail-host-address) + (string-match "\\." mail-host-address)) mail-host-address) + ;; We try `user-mail-address' as a backup. + ((and (string-match "\\." user-mail) + (string-match "@\\(.*\\)\\'" user-mail)) + (match-string 1 user-mail)) ;; Default to this bogus thing. (t (concat system-name ".i-have-a-misconfigured-system-so-shoot-me"))))) (defun message-make-host-name () "Return the name of the host." - (let ((fqdm (message-make-fqdm))) - (string-match "^[^.]+\\." fqdm) - (substring fqdm 0 (1- (match-end 0))))) + (let ((fqdn (message-make-fqdn))) + (string-match "^[^.]+\\." fqdn) + (substring fqdn 0 (1- (match-end 0))))) (defun message-make-domain () "Return the domain name." (or mail-host-address - (message-make-fqdm))) + (message-make-fqdn))) (defun message-generate-headers (headers) "Prepare article HEADERS. @@ -1692,7 +2074,7 @@ Headers already prepared in the buffer are not modified." (Distribution (message-make-distribution)) (Lines (message-make-lines)) (X-Newsreader message-newsreader) - (X-Mailer (and (not (mail-fetch-field "X-Newsreader")) + (X-Mailer (and (not (message-fetch-field "X-Newsreader")) message-mailer)) (Expires (message-make-expires)) (case-fold-search t) @@ -1774,8 +2156,8 @@ Headers already prepared in the buffer are not modified." (point) (match-end 0) '(message-deletable t face italic) (current-buffer))))))) ;; Insert new Sender if the From is strange. - (let ((from (mail-fetch-field "from")) - (sender (mail-fetch-field "sender")) + (let ((from (message-fetch-field "from")) + (sender (message-fetch-field "sender")) (secure-sender (message-make-sender))) (when (and from (not (message-check-element 'sender)) @@ -1802,7 +2184,7 @@ Headers already prepared in the buffer are not modified." (save-excursion (save-restriction (message-narrow-to-headers) - (let ((newsgroups (mail-fetch-field "newsgroups"))) + (let ((newsgroups (message-fetch-field "newsgroups"))) (when newsgroups (goto-char (point-max)) (insert "Posted-To: " newsgroups "\n")))) @@ -1813,11 +2195,40 @@ Headers already prepared in the buffer are not modified." ;;; Setting up a message buffer ;;; +(defun message-fill-address (header value) + (save-restriction + (narrow-to-region (point) (point)) + (insert (capitalize (symbol-name header)) + ": " + (if (consp value) (car value) value) + "\n") + (narrow-to-region (point-min) (1- (point-max))) + (let (quoted last) + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward "^,\"" (point-max)) + (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))))) + (setq quoted (not quoted))) + (unless (eobp) + (forward-char 1)))) + (goto-char (point-max)) + (widen) + (forward-line 1))) + (defun message-fill-header (header value) (let ((begin (point)) (fill-column 78) - (fill-prefix "\t") - end) + (fill-prefix "\t")) (insert (capitalize (symbol-name header)) ": " (if (consp value) (car value) value) @@ -1835,12 +2246,6 @@ Headers already prepared in the buffer are not modified." (replace-match " " t t)) (goto-char (point-max))))) -(defun sendmail-synch-aliases () - (let ((modtime (nth 5 (file-attributes message-personal-alias-file)))) - (or (equal message-alias-modtime modtime) - (setq message-alias-modtime modtime - message-aliases t)))) - (defun message-position-point () "Move point to where the user probably wants to find it." (message-narrow-to-headers) @@ -1860,6 +2265,28 @@ Headers already prepared in the buffer are not modified." (forward-line 2))) (sit-for 0))) +(defun message-buffer-name (type &optional to group) + "Return a new (unique) buffer name based on TYPE and TO." + (cond + ;; Check whether `message-generate-new-buffers' is a function, + ;; and if so, call it. + ((message-functionp message-generate-new-buffers) + (funcall message-generate-new-buffers type to group)) + ;; Generate a new buffer name The Message Way. + (message-generate-new-buffers + (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) "") + "*"))) + ;; Use standard name. + (t + (format "*%s message*" type)))) + (defun message-pop-to-buffer (name) "Pop to buffer NAME, and warn if it already exists and is modified." (let ((buffer (get-buffer name))) @@ -1871,12 +2298,42 @@ 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." + ;; We might have sent this buffer already. Delete it from the + ;; list of buffers. + (setq message-buffer-list (delq (current-buffer) message-buffer-list)) + (while (and message-max-buffers + (>= (length message-buffer-list) message-max-buffers)) + ;; Kill the oldest buffer -- unless it has been changed. + (let ((buffer (pop message-buffer-list))) + (when (and (buffer-name buffer) + (not (buffer-modified-p buffer))) + (kill-buffer buffer)))) + ;; Rename the buffer. + (if message-send-rename-function + (funcall message-send-rename-function) + (when (string-match "\\`\\*" (buffer-name)) + (rename-buffer + (concat "*sent " (substring (buffer-name) (match-end 0))) t))) + ;; Push the current buffer onto the list. + (when message-max-buffers + (setq message-buffer-list + (nconc message-buffer-list (list (current-buffer)))))) + +(defvar mc-modes-alist) (defun message-setup (headers &optional replybuffer actions) - (setq message-send-actions actions) + (when (and (boundp 'mc-modes-alist) + (not (assq 'message-mode mc-modes-alist))) + (push '(message-mode (encrypt . mc-encrypt-message) + (sign . mc-sign-message)) + mc-modes-alist)) + (when actions + (setq message-send-actions actions)) (setq message-reply-buffer replybuffer) (goto-char (point-min)) ;; Insert all the headers. @@ -1889,21 +2346,33 @@ Headers already prepared in the buffer are not modified." (pop h)) alist) headers) - (forward-line -1) + (delete-region (point) (progn (forward-line -1) (point))) (when message-default-headers (insert message-default-headers)) - (insert mail-header-separator "\n") + (put-text-property + (point) + (progn + (insert mail-header-separator "\n") + (1- (point))) + 'read-only nil) (forward-line -1) - (when (and (message-news-p) - message-default-news-headers) + (when (message-news-p) + (when message-default-news-headers + (insert message-default-news-headers)) (when message-generate-headers-first - (message-generate-headers message-required-news-headers)) - (insert message-default-news-headers)) - (when (and (message-mail-p) - message-default-mail-headers) + (message-generate-headers + (delq 'Lines + (delq 'Subject + (copy-sequence message-required-news-headers)))))) + (when (message-mail-p) + (when message-default-mail-headers + (insert message-default-mail-headers)) (when message-generate-headers-first - (message-generate-headers message-required-mail-headers)) - (insert message-default-mail-headers)) + (message-generate-headers + (delq 'Lines + (delq 'Subject + (copy-sequence message-required-mail-headers)))))) + (run-hooks 'message-signature-setup-hook) (message-insert-signature) (message-set-auto-save-file-name) (save-restriction @@ -1942,24 +2411,25 @@ Headers already prepared in the buffer are not modified." (defun message-mail (&optional to subject) "Start editing a mail message to be sent." (interactive) - (message-pop-to-buffer "*mail message*") + (message-pop-to-buffer (message-buffer-name "mail" to)) (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))) ;;;###autoload (defun message-news (&optional newsgroups subject) "Start editing a news article to be sent." (interactive) - (message-pop-to-buffer "*news message*") + (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)) (message-setup `((Newsgroups . ,(or newsgroups "")) (Subject . ,(or subject ""))))) ;;;###autoload -(defun message-reply (&optional to-address wide) +(defun message-reply (&optional to-address wide ignore-reply-to) "Start editing a reply to the article in the current buffer." (interactive) (let ((cur (current-buffer)) - from subject date reply-to message-of to cc - references message-id sender follow-to sendto elt new-cc new-to + from subject date reply-to to cc + references message-id follow-to + (inhibit-point-motion-hooks t) mct never-mct gnus-warning) (save-restriction (narrow-to-region @@ -1978,23 +2448,22 @@ Headers already prepared in the buffer are not modified." (setq follow-to (funcall message-wide-reply-to-function))))) ;; Find all relevant headers we need. - (setq from (mail-fetch-field "from") - date (mail-fetch-field "date") - sender (mail-fetch-field "sender") - subject (or (mail-fetch-field "subject") "none") - to (mail-fetch-field "to") - cc (mail-fetch-field "cc") - mct (mail-fetch-field "mail-copies-to") - reply-to (mail-fetch-field "reply-to") - references (mail-fetch-field "references") - message-id (mail-fetch-field "message-id")) + (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")) + references (message-fetch-field "references") + message-id (message-fetch-field "message-id")) ;; Remove any (buggy) Re:'s that are present and make a ;; proper one. - (when (string-match "^[ \t]*[Re][Ee]:[ \t]*" subject) + (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject) (setq subject (substring subject (match-end 0)))) (setq subject (concat "Re: " subject)) - (when (and (setq gnus-warning (mail-fetch-field "gnus-warning")) + (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) (string-match "<[^>]+>" gnus-warning)) (setq message-id (match-string 0 gnus-warning))) @@ -2015,10 +2484,9 @@ Headers already prepared in the buffer are not modified." (message-set-work-buffer) (unless never-mct (insert (or reply-to from ""))) - (insert - (if (bolp) "" ", ") (or to "") - (if mct (concat (if (bolp) "" ", ") mct) "") - (if cc (concat (if (bolp) "" ", ") cc) "")) + (insert (if (bolp) "" ", ") (or to "")) + (insert (if mct (concat (if (bolp) "" ", ") mct) "")) + (insert (if cc (concat (if (bolp) "" ", ") cc) "")) ;; Remove addresses that match `rmail-dont-reply-to-names'. (insert (prog1 (rmail-dont-reply-to (buffer-string)) (erase-buffer))) @@ -2027,7 +2495,7 @@ Headers already prepared in the buffer are not modified." (mapcar (lambda (addr) (cons (mail-strip-quoted-names addr) addr)) - (nreverse (mail-parse-comma-list)))) + (message-tokenize-header (buffer-string)))) (let ((s ccalist)) (while s (setq ccalist (delq (assoc (car (pop s)) s) ccalist))))) @@ -2038,7 +2506,9 @@ Headers already prepared in the buffer are not modified." follow-to))))) (widen)) - (message-pop-to-buffer "*mail message*") + (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 "")) @@ -2046,8 +2516,10 @@ Headers already prepared in the buffer are not modified." (message-setup `((Subject . ,subject) ,@follow-to - (References . ,(concat (or references "") (and references " ") - (or message-id "")))) + ,@(if (or references message-id) + `((References . ,(concat (or references "") (and references " ") + (or message-id "")))) + nil)) cur))) ;;;###autoload @@ -2059,8 +2531,9 @@ Headers already prepared in the buffer are not modified." (defun message-followup () (interactive) (let ((cur (current-buffer)) - from subject date message-of reply-to mct - references message-id follow-to sendto elt + from subject date reply-to mct + references message-id follow-to + (inhibit-point-motion-hooks t) followup-to distribution newsgroups gnus-warning) (save-restriction (narrow-to-region @@ -2071,17 +2544,17 @@ Headers already prepared in the buffer are not modified." (when (message-functionp message-followup-to-function) (setq follow-to (funcall message-followup-to-function))) - (setq from (mail-fetch-field "from") - date (mail-fetch-field "date") - subject (or (mail-fetch-field "subject") "none") - references (mail-fetch-field "references") - message-id (mail-fetch-field "message-id") - followup-to (mail-fetch-field "followup-to") - newsgroups (mail-fetch-field "newsgroups") - reply-to (mail-fetch-field "reply-to") - distribution (mail-fetch-field "distribution") - mct (mail-fetch-field "mail-copies-to")) - (when (and (setq gnus-warning (mail-fetch-field "gnus-warning")) + (setq from (message-fetch-field "from") + date (message-fetch-field "date") + subject (or (message-fetch-field "subject") "none") + references (message-fetch-field "references") + message-id (message-fetch-field "message-id") + followup-to (message-fetch-field "followup-to") + newsgroups (message-fetch-field "newsgroups") + 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)) (setq message-id (match-string 0 gnus-warning))) ;; Remove bogus distribution. @@ -2090,12 +2563,12 @@ Headers already prepared in the buffer are not modified." (setq distribution nil)) ;; Remove any (buggy) Re:'s that are present and make a ;; proper one. - (when (string-match "^[ \t]*[Re][Ee]:[ \t]*" subject) + (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject) (setq subject (substring subject (match-end 0)))) (setq subject (concat "Re: " subject)) (widen)) - (message-pop-to-buffer "*news message*") + (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) (message-setup `((Subject . ,subject) @@ -2106,13 +2579,34 @@ Headers already prepared in the buffer are not modified." (cond ((equal (downcase followup-to) "poster") (if (or (eq message-use-followup-to 'use) - (y-or-n-p "Use Followup-To \"poster\"? ")) + (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. + +A typical situation where `Followup-To: poster' is used is when the poster +does not read the newsgroup, so he wouldn't see any replies sent to it.")) (cons 'To (or reply-to from "")) (cons 'Newsgroups newsgroups))) (t (if (or (equal followup-to newsgroups) (not (eq message-use-followup-to 'ask)) - (y-or-n-p (format "Use Followup-To %s? " followup-to))) + (message-y-or-n-p + (concat "Obey Followup-To: " followup-to "? ") t "\ +You should normally obey the Followup-To: header. + + `Followup-To: " followup-to "' +directs your response to " (if (string-match "," followup-to) + "the specified newsgroups" + "that newsgroup only") ". + +If a message is posted to several newsgroups, Followup-To is often +used to direct the following discussion to one newsgroup only, +because discussions that are spread over several newsgroup tend to +be fragmented and very difficult to follow. + +Also, some source/announcment newsgroups are not indented for discussion; +responses here are directed to other newsgroups.")) (cons 'Newsgroups followup-to) (cons 'Newsgroups newsgroups)))))) (t @@ -2138,39 +2632,39 @@ Headers already prepared in the buffer are not modified." (interactive) (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) - (save-excursion - ;; Get header info. from original article. - (save-restriction - (message-narrow-to-head) - (setq from (mail-fetch-field "from") - newsgroups (mail-fetch-field "newsgroups") - message-id (mail-fetch-field "message-id") - distribution (mail-fetch-field "distribution"))) - ;; Make sure that this article was written by the user. - (unless (string-equal - (downcase (mail-strip-quoted-names from)) - (downcase (message-make-address))) - (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" - "Subject: cmsg cancel " message-id "\n" - "Control: cancel " message-id "\n" - (if distribution - (concat "Distribution: " distribution "\n") - "") - mail-header-separator "\n" - "This is a cancel message from " from ".\n") - (message "Canceling your article...") - (let (message-syntax-checks) - (funcall message-send-news-function)) - (message "Canceling your article...done") - (kill-buffer buf)))) + (when (yes-or-no-p "Do you really want to cancel this article? ") + (let (from newsgroups message-id distribution buf) + (save-excursion + ;; Get header info. from original article. + (save-restriction + (message-narrow-to-head) + (setq from (message-fetch-field "from") + newsgroups (message-fetch-field "newsgroups") + message-id (message-fetch-field "message-id") + 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))) + (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" + "Subject: cmsg cancel " message-id "\n" + "Control: cancel " message-id "\n" + (if distribution + (concat "Distribution: " distribution "\n") + "") + mail-header-separator "\n" + "This is a cancel message from " from ".\n") + (message "Canceling your article...") + (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 () @@ -2181,11 +2675,12 @@ header line with the old Message-ID." (let ((cur (current-buffer))) ;; Check whether the user owns the article that is to be superseded. (unless (string-equal - (downcase (mail-strip-quoted-names (mail-fetch-field "from"))) - (downcase (mail-strip-quoted-names (message-make-address)))) + (downcase (cadr (mail-extract-address-components + (message-fetch-field "from")))) + (downcase (message-make-address))) (error "This article is not yours")) ;; Get a normal message buffer. - (message-pop-to-buffer "*supersede message*") + (message-pop-to-buffer (message-buffer-name "supersede")) (insert-buffer-substring cur) (message-narrow-to-head) ;; Remove unwanted headers. @@ -2222,8 +2717,9 @@ header line with the old Message-ID." (defun message-make-forward-subject () "Return a Subject header suitable for the message in the current buffer." - (concat "[" (mail-fetch-field (if (message-news-p) "newsgroups" "from")) - "] " (or (mail-fetch-field "Subject") ""))) + (concat "[" (or (message-fetch-field (if (message-news-p) "newsgroups" "from")) + "(nowhere)") + "] " (or (message-fetch-field "Subject") ""))) ;;;###autoload (defun message-forward (&optional news) @@ -2238,6 +2734,9 @@ Optional NEWS will use news to forward instead of mail." (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. @@ -2265,12 +2764,13 @@ Optional NEWS will use news to forward instead of mail." (let ((cur (current-buffer)) beg) ;; We first set up a normal mail buffer. - (message-set-work-buffer) + (set-buffer (get-buffer-create " *message resend*")) + (buffer-disable-undo (current-buffer)) + (erase-buffer) (message-setup `((To . ,address))) ;; Insert our usual headers. - (message-narrow-to-headers) (message-generate-headers '(From Date To)) - (goto-char (point-min)) + (message-narrow-to-headers) ;; Rename them all to "Resent-*". (while (re-search-forward "^[A-Za-z]" nil t) (forward-char -1) @@ -2294,7 +2794,8 @@ Optional NEWS will use news to forward instead of mail." (beginning-of-line) (insert "Also-")) ;; Send it. - (funcall message-send-mail-function)))) + (message-send-mail) + (kill-buffer (current-buffer))))) ;;;###autoload (defun message-bounce () @@ -2302,19 +2803,33 @@ Optional NEWS will use news to forward instead of mail." This only makes sense if the current message is a bounce message than contains some mail you have written which has been bounced back to you." - (interactive "P") - (let ((cur (current-buffer))) - (message-pop-to-buffer "*mail message*") + (interactive) + (let ((cur (current-buffer)) + 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)) - (or (and (re-search-forward mail-unsent-separator nil t) + (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)) (and (search-forward "\n\n" nil t) (re-search-forward "^Return-Path:.*\n" nil t))) ;; We remove everything before the bounced mail. (delete-region (point-min) - (if (re-search-forward "[^ \t]*:" nil t) + (if (re-search-forward "^[^ \n\t]+:" nil t) (match-beginning 0) (point))) (save-restriction @@ -2337,7 +2852,7 @@ you." (special-display-regexps nil) (same-window-buffer-names nil) (same-window-regexps nil)) - (message-pop-to-buffer "*mail message*")) + (message-pop-to-buffer (message-buffer-name "mail" to))) (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))) ;;;###autoload @@ -2349,7 +2864,7 @@ you." (special-display-regexps nil) (same-window-buffer-names nil) (same-window-regexps nil)) - (message-pop-to-buffer "*mail message*")) + (message-pop-to-buffer (message-buffer-name "mail" to))) (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))) ;;;###autoload @@ -2361,7 +2876,7 @@ you." (special-display-regexps nil) (same-window-buffer-names nil) (same-window-regexps nil)) - (message-pop-to-buffer "*news message*")) + (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))) (message-setup `((Newsgroups . ,(or newsgroups "")) (Subject . ,(or subject ""))))) @@ -2374,7 +2889,7 @@ you." (special-display-regexps nil) (same-window-buffer-names nil) (same-window-regexps nil)) - (message-pop-to-buffer "*news message*")) + (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))) (message-setup `((Newsgroups . ,(or newsgroups "")) (Subject . ,(or subject ""))))) @@ -2412,6 +2927,91 @@ which specify the range to operate on." (if (eq (following-char) (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) + (require 'messagexmas)) + +;;; Group name completion. + +(defvar message-newgroups-header-regexp + "^\\(Newsgroups\\|Followup-To\\|Posted-To\\):" + "Regexp that match headers that lists groups.") + +(defun message-tab () + "Expand group names in Newsgroups and Followup-To headers. +Do a `tab-to-tab-stop' if not in those headers." + (interactive) + (if (let ((mail-abbrev-mode-regexp message-newgroups-header-regexp)) + (mail-abbrev-in-expansion-header-p)) + (message-expand-group) + (tab-to-tab-stop))) + +(defvar gnus-active-hashtb) +(defun message-expand-group () + (let* ((b (save-excursion (skip-chars-backward "^, :\t\n") (point))) + (completion-ignore-case t) + (string (buffer-substring b (point))) + (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb)) + (completions (all-completions string hashtb)) + (cur (current-buffer)) + comp) + (delete-region b (point)) + (cond + ((= (length completions) 1) + (if (string= (car completions) string) + (progn + (insert string) + (message "Only matching group")) + (insert (car completions)))) + ((and (setq comp (try-completion string hashtb)) + (not (string= comp string))) + (insert comp)) + (t + (insert string) + (if (not comp) + (message "No matching groups") + (pop-to-buffer "*Completions*") + (buffer-disable-undo (current-buffer)) + (let ((buffer-read-only nil)) + (erase-buffer) + (let ((standard-output (current-buffer))) + (display-completion-list (sort completions 'string<))) + (goto-char (point-min)) + (pop-to-buffer cur))))))) + +;;; Help stuff. + +(defmacro message-y-or-n-p (question show &rest text) + "Ask QUESTION, displaying the rest of the arguments in a temp. buffer if SHOW" + `(message-talkative-question 'y-or-n-p ,question ,show ,@text)) + +(defun message-talkative-question (ask question show &rest text) + "Call FUNCTION with argument QUESTION, displaying the rest of the arguments in a temporary buffer if SHOW. +The following arguments may contain lists of values." + (if (and show + (setq text (message-flatten-list text))) + (save-window-excursion + (save-excursion + (with-output-to-temp-buffer " *MESSAGE information message*" + (set-buffer " *MESSAGE information message*") + (mapcar 'princ text) + (goto-char (point-min)))) + (funcall ask question)) + (funcall ask question))) + +(defun message-flatten-list (&rest list) + (message-flatten-list-1 list)) + +(defun message-flatten-list-1 (list) + (cond ((consp list) + (apply 'append (mapcar 'message-flatten-list-1 list))) + (list + (list list)))) + +(run-hooks 'message-load-hook) + (provide 'message) ;;; message.el ends here