X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=570eb91406acb2bdedb34240610cd1bd20ebee1a;hb=926bcf02432a9bed8ce9f17224e91c514b2a5093;hp=9298c8356c47e0991b7a7981d15896d669987b8a;hpb=05f55b4d455361428a1faaa99ec73b0416b2fcf6;p=gnus diff --git a/lisp/message.el b/lisp/message.el index 9298c8356..570eb9140 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -31,33 +31,61 @@ (eval-when-compile (require 'cl)) -(require 'mail-header) +(require 'mailheader) +(require 'rmail) (require 'nnheader) (require 'timezone) (require 'easymenu) +(require 'custom) (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.") +(defgroup message nil + "Mail and news message composing." + :group 'emacs) + +(defcustom message-directory "~/Mail/" + "*Directory from which all other mail file variables are derived." + :group 'message + :type 'directory) + +(defcustom message-max-buffers 10 + "*How many buffers to keep before starting to kill them off." + :group 'message + :type 'integer) + +(defcustom message-send-rename-function nil + "Function called to rename the buffer after sending it." + :group 'message + :type 'function) ;;;###autoload (defvar message-fcc-handler-function 'rmail-output "*A function called to save outgoing articles. This function will be called with the name of the file to store the -article in. The default function is `rmail-output' which saves in Unix +article in. The default function is `rmail-output' which saves in Unix mailbox format.") - -;;;###autoload -(defvar message-courtesy-message - "The following message is a courtesy copy of an article\nthat has been posted as well.\n\n" +(put 'message-fcc-handler-function + 'custom-type '(radio (function-item rmail-output) + (function :tag "Other"))) +(put 'message-fcc-handler-function + 'factory-value '('rmail-output)) +(custom-add-to-group 'message 'message-fcc-handler-function 'custom-variable) + +(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. -If this variable is nil, no such courtesy message will be added.") +If the string contains the format spec \"%s\", the Newsgroups +the article has been posted to will be inserted there. +If this variable is nil, no such courtesy message will be added." + :group 'message + :type 'string) -;;;###autoload -(defvar message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):" - "*Regexp that matches headers to be removed in resent bounced mail.") +(defcustom message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):" + "*Regexp that matches headers to be removed in resent bounced mail." + :group 'message + :type 'regexp) ;;;###autoload (defvar message-from-style 'default @@ -72,9 +100,17 @@ If `angles', they look like: Otherwise, most addresses look like `angles', but they look like `parens' if `angles' would need quoting and `parens' would not.") +(put 'message-from-style + 'custom-type '(choice (const :tag "simple" nil) + (const parens) + (const angles) + (const default))) +(put 'message-from-style + 'factory-value '('default)) +(custom-add-to-group 'message 'message-from-style 'custom-variable) -;;;###autoload (defvar message-syntax-checks nil + ;; Guess this one shouldn't be easy to customize... "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. @@ -83,108 +119,148 @@ 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.") +approved sender empty empty-headers message-id from subject +shorten-followup-to existing-newsgroups.") -;;;###autoload -(defvar message-required-news-headers +(defcustom message-required-news-headers '(From Newsgroups Subject Date Message-ID (optional . Organization) Lines (optional . X-Newsreader)) - "*Headers to be generated or prompted for when posting an article. + "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 -header, remove it from this list.") +header, remove it from this list." + :group 'message + :type 'sexp) -;;;###autoload -(defvar message-required-mail-headers +(defcustom message-required-mail-headers '(From Subject Date (optional . In-Reply-To) Message-ID Lines (optional . X-Mailer)) - "*Headers to be generated or prompted for when mailing a message. + "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.") - -;;;###autoload -(defvar message-deletable-headers '(Message-ID Date) - "*Headers to be deleted if they already exist and were generated by message previously.") - -;;;###autoload -(defvar message-ignored-news-headers - "^NNTP-Posting-Host:\\|^Xref:\\|^Bcc:\\|^Gcc:\\|^Fcc:" - "*Regexp of headers to be removed unconditionally before posting.") - -;;;###autoload -(defvar message-ignored-mail-headers "^Gcc:\\|^Fcc:" - "*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:" +included. Organization, Lines and X-Mailer are optional." + :group 'message + :type 'sexp) + +(defcustom message-deletable-headers '(Message-ID Date Lines) + "Headers to be deleted if they already exist and were generated by message previously." + :group 'message + :type 'sexp) + +(defcustom message-ignored-news-headers + "^NNTP-Posting-Host:\\|^Xref:\\|^Bcc:\\|^Gcc:\\|^Fcc:\\|^Resent-Fcc:" + "*Regexp of headers to be removed unconditionally before posting." + :group 'message + :type 'regexp) + +(defcustom message-ignored-mail-headers "^Gcc:\\|^Fcc:\\|^Resent-Fcc:" + "*Regexp of headers to be removed unconditionally before mailing." + :group 'message + :type 'regexp) + +(defcustom 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.") +any confusion." + :group 'message + :type 'regexp) ;;;###autoload (defvar message-signature-separator "^-- *$" "Regexp matching the signature separator.") +(put 'message-signature-separator + 'custom-type 'regexp) +(put 'message-signature-separator + 'factory-value '("^-- *$")) +(custom-add-to-group 'message 'message-signature-separator 'custom-variable) -;;;###autoload -(defvar message-interactive nil +(defcustom 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.") - -;;;###autoload -(defvar message-generate-new-buffers nil - "*Non-nil means that a new message buffer will be created whenever `mail-setup' is called.") - -;;;###autoload -(defvar message-kill-buffer-on-exit nil - "*Non-nil means that the message buffer will be killed after sending a message.") +nil means let mailer mail back a message to report errors." + :group 'message + :type 'boolean) + +(defcustom 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." + :group 'message + :type '(choice (const :tag "off" nil) + (const :tag "on" t) + (function fun))) + +(defcustom message-kill-buffer-on-exit nil + "*Non-nil means that the message buffer will be killed after sending a message." + :group 'message + :type 'boolean) (defvar gnus-local-organization) -;;;###autoload -(defvar message-user-organization +(defcustom message-user-organization (or (and (boundp 'gnus-local-organization) gnus-local-organization) (getenv "ORGANIZATION") t) "*String to be used as an Organization header. -If t, use `message-user-organization-file'.") +If t, use `message-user-organization-file'." + :group 'message + :type '(choice string + (const :tag "consult file" t))) ;;;###autoload (defvar message-user-organization-file "/usr/lib/news/organization" "*Local news organization file.") - -;;;###autoload -(defvar message-autosave-directory - (concat (file-name-as-directory message-directory) "drafts/") +(put 'message-user-organization-file + 'custom-type 'file) +(put 'message-user-organization-file + 'factory-value '("/usr/lib/news/organization")) +(custom-add-to-group 'message 'message-user-organization-file 'custom-variable) + +(defcustom message-autosave-directory "~/" + ; (concat (file-name-as-directory message-directory) "drafts/") "*Directory where message autosaves buffers. -If nil, message won't autosave.") +If nil, message won't autosave." + :group 'message + :type 'directory) -(defvar message-forward-start-separator +(defcustom message-forward-start-separator "------- Start of forwarded message -------\n" - "*Delimiter inserted before forwarded messages.") + "*Delimiter inserted before forwarded messages." + :group 'message + :type 'string) -(defvar message-forward-end-separator +(defcustom message-forward-end-separator "------- End of forwarded message -------\n" - "*Delimiter inserted after forwarded messages.") + "*Delimiter inserted after forwarded messages." + :group 'message + :type 'string) -;;;###autoload -(defvar message-signature-before-forwarded-message t - "*If non-nil, put the signature before any included forwarded message.") +(defcustom message-signature-before-forwarded-message t + "*If non-nil, put the signature before any included forwarded message." + :group 'message + :type 'boolean) -;;;###autoload -(defvar message-included-forward-headers +(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:" - "*Regexp matching headers to be included in forwarded messages.") + "*Regexp matching headers to be included in forwarded messages." + :group 'message + :type 'regexp) -;;;###autoload -(defvar message-ignored-resent-headers "^Return-receipt" - "*All headers that match this regexp will be deleted when resending a message.") +(defcustom message-ignored-resent-headers "^Return-receipt" + "*All headers that match this regexp will be deleted when resending a message." + :group 'message + :type 'regexp) -;;;###autoload -(defvar message-ignored-cited-headers "." - "Delete these headers from the messages you yank.") +(defcustom message-ignored-cited-headers "." + "*Delete these headers from the messages you yank." + :group 'message + :type 'regexp) + +(defcustom message-cancel-message "I am canceling my own article." + "Message to be inserted in the cancel message." + :group 'message + :type 'string) ;; Useful to set in site-init.el ;;;###autoload @@ -193,84 +269,162 @@ If nil, message won't autosave.") The headers should be delimited by a line whose contents match the variable `mail-header-separator'. -Legal values include `message-send-mail-with-mh' and -`message-send-mail-with-sendmail', which is the default.") +Legal values include `message-send-mail-with-sendmail' (the default), +`message-send-mail-with-mh' and `message-send-mail-with-qmail'.") +(put 'message-send-mail-function + 'custom-type '(radio (function-item message-send-mail-with-sendmail) + (function-item message-send-mail-with-mh) + (function-item message-send-mail-with-qmail) + (function :tag "Other"))) +(put 'message-send-mail-function + 'factory-value '('rmail-output)) +(custom-add-to-group 'message 'message-send-mail-function 'custom-variable) -;;;###autoload -(defvar message-send-news-function 'message-send-news + +(defcustom 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'." + :group 'message + :type 'function) -;;;###autoload -(defvar message-reply-to-function nil +(defcustom message-reply-to-function nil "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.") +and respond with new To and Cc headers." + :group 'message + :type 'function) -;;;###autoload -(defvar message-wide-reply-to-function nil +(defcustom message-wide-reply-to-function nil "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.") +and respond with new To and Cc headers." + :group 'message + :type 'function) -;;;###autoload -(defvar message-followup-to-function nil +(defcustom message-followup-to-function nil "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.") +and respond with new To and Cc headers." + :group 'message + :type 'function) -;;;###autoload -(defvar message-use-followup-to 'ask +(defcustom 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 query before +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.") +always use the value." + :group 'message + :type '(choice (const :tag "ignore" nil) + (const use) + (const ask))) + +;; qmail-related stuff +(defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject" + "Location of the qmail-inject program." + :group 'message + :type 'file) + +(defcustom message-qmail-inject-args nil + "Arguments passed to qmail-inject programs. +This should be a list of strings, one string for each argument. + +For e.g., if you wish to set the envelope sender address so that bounces +go to the right place or to deal with listserv's usage of that address, you +might set this variable to '(\"-f\" \"you@some.where\")." + :group 'message + :type '(repeat string)) (defvar gnus-post-method) (defvar gnus-select-method) -;;;###autoload -(defvar message-post-method +(defcustom message-post-method (cond ((and (boundp 'gnus-post-method) gnus-post-method) gnus-post-method) ((boundp 'gnus-select-method) gnus-select-method) (t '(nnspool ""))) - "Method used to post news.") - -;;;###autoload -(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.") - -(defvar message-setup-hook nil + "Method used to post news." + :group 'message + ;; This should be the `gnus-select-method' widget, but that might + ;; create a dependence to `gnus.el'. + :type 'sexp) + +(defcustom message-generate-headers-first nil + "*If non-nil, generate all possible headers before composing." + :group 'message + :type 'boolean) + +(defcustom message-setup-hook nil "Normal hook, run each time a new outgoing message is initialized. -The function `message-setup' runs this hook.") +The function `message-setup' runs this hook." + :group 'message + :type 'hook) -(defvar message-header-setup-hook nil - "Hook called narrowed to the headers when setting up a message buffer.") +(defcustom message-signature-setup-hook nil + "Normal hook, run each time a new outgoing message is initialized. +It is run after the headers have been inserted and before +the signature is inserted." + :group 'message + :type 'hook) + +(defcustom message-mode-hook nil + "Hook run in message mode buffers." + :group 'message + :type 'hook) + +(defcustom message-header-hook nil + "Hook run in a message mode buffer narrowed to the headers." + :group 'message + :type 'hook) + +(defcustom message-header-setup-hook nil + "Hook called narrowed to the headers when setting up a message +buffer." + :group 'message + :type 'hook) ;;;###autoload (defvar message-citation-line-function 'message-insert-citation-line "*Function called to insert the \"Whomever writes:\" line.") +(put 'message-citation-line-function + 'custom-type 'function) +(put 'message-citation-line-function + 'factory-value '('message-insert-citation-line)) +(custom-add-to-group 'message 'message-citation-line-function 'custom-variable) + ;;;###autoload (defvar message-yank-prefix "> " "*Prefix inserted on the lines of yanked messages. nil means use indentation.") +(put 'message-yank-prefix + 'custom-type 'string) +(put 'message-yank-prefix + 'factory-value '("> ")) +(custom-add-to-group 'message 'message-yank-prefix 'custom-variable) -(defvar message-indentation-spaces 3 +(defcustom message-indentation-spaces 3 "*Number of spaces to insert at the beginning of each cited line. -Used by `message-yank-original' via `message-yank-cite'.") +Used by `message-yank-original' via `message-yank-cite'." + :group 'message + :type 'integer) ;;;###autoload -(defvar message-cite-function 'message-cite-original +(defvar message-cite-function + (if (and (boundp 'mail-citation-hook) + mail-citation-hook) + mail-citation-hook + 'message-cite-original) "*Function for citing an original message.") +(put 'message-cite-function + 'custom-type '(radio (function-item message-cite-original) + (function-item sc-cite-original) + (function :tag "Other"))) +(put 'message-cite-function + 'factory-value '('message-cite-original)) +(custom-add-to-group 'message 'message-cite-function 'custom-variable) ;;;###autoload (defvar message-indent-citation-function 'message-indent-citation @@ -278,6 +432,11 @@ Used by `message-yank-original' via `message-yank-cite'.") This can also be a list of functions. Each function can find the citation between (point) and (mark t). And each function should leave point and mark around the citation text as modified.") +(put 'message-indent-citation-function + 'custom-type 'function) +(put 'message-indent-citation-function + 'factory-value '('message-indent-citation)) +(custom-add-to-group 'message 'message-indent-citation-function 'custom-variable) (defvar message-abbrevs-loaded nil) @@ -287,20 +446,38 @@ point and mark around the citation text as modified.") 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.") +(put 'message-signature + 'custom-type 'sexp) +(put 'message-signature + 'factory-value '(t)) +(custom-add-to-group 'message 'message-signature 'custom-variable) ;;;###autoload (defvar message-signature-file "~/.signature" - "*File containing the text inserted at end of message. buffer.") - -(defvar message-distribution-function nil - "*Function called to return a Distribution header.") - -(defvar message-expires 14 - "*Number of days before your article expires.") - -(defvar message-user-path nil + "*File containing the text inserted at end of message buffer.") +(put 'message-signature-file + 'custom-type 'file) +(put 'message-signature-file + 'factory-value '("~/.signature")) +(custom-add-to-group 'message 'message-signature-file 'custom-variable) + +(defcustom message-distribution-function nil + "*Function called to return a Distribution header." + :group 'message + :type 'function) + +(defcustom message-expires 14 + "*Number of days before your article expires." + :group 'message + :type 'integer) + +(defcustom message-user-path nil "If nil, use the NNTP server name in the Path header. -If stringp, use this; if non-nil, use no host name (user name only).") +If stringp, use this; if non-nil, use no host name (user name only)." + :group 'message + :type '(choice (const :tag "nntp" nil) + (string :tag "name") + (sexp :tag "none" :format "%t" t))) (defvar message-reply-buffer nil) (defvar message-reply-headers nil) @@ -317,23 +494,27 @@ If stringp, use this; if non-nil, use no host name (user name only).") (defvar message-postpone-actions nil "A list of actions to be performed after postponing a message.") -;;;###autoload -(defvar message-default-headers nil +(defcustom message-default-headers "" "*A string containing header lines to be inserted in outgoing messages. It is inserted before you edit the message, so you can edit or delete -these lines.") +these lines." + :group 'message + :type 'string) -;;;###autoload -(defvar message-default-mail-headers nil - "*A string of header lines to be inserted in outgoing mails.") +(defcustom message-default-mail-headers "" + "*A string of header lines to be inserted in outgoing mails." + :group 'message + :type 'string) -;;;###autoload -(defvar message-default-news-headers nil - "*A string of header lines to be inserted in outgoing news articles.") +(defcustom message-default-news-headers "" + "*A string of header lines to be inserted in outgoing news +articles." + :group 'message + :type 'string) ;; Note: could use /usr/ucb/mail instead of sendmail; ;; options -t, and -v if not interactive. -(defvar message-mailer-swallows-blank-line +(defcustom message-mailer-swallows-blank-line (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)" system-configuration) (file-readable-p "/etc/sendmail.cf") @@ -347,14 +528,19 @@ these lines.") (re-search-forward "^OR\\>" nil t))) (kill-buffer buffer)))) ;; According to RFC822, "The field-name must be composed of printable - ;; ASCII characters (i.e. characters that have decimal values between - ;; 33 and 126, except colon)", i.e. any chars except ctl chars, + ;; ASCII characters (i. e., characters that have decimal values between + ;; 33 and 126, except colon)", i. e., any chars except ctl chars, ;; space, or colon. '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:")) "Set this non-nil if the system's mailer runs the header and body together. \(This problem exists on Sunos 4 when sendmail is run in remote mode.) The value should be an expression to test whether the problem will -actually occur.") +actually occur." + :group 'message + :type 'sexp) + +;;; Internal variables. +;;; Well, not really internal. (defvar message-mode-syntax-table (let ((table (copy-syntax-table text-mode-syntax-table))) @@ -362,6 +548,10 @@ 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) @@ -374,7 +564,7 @@ actually occur.") "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" "[>|}].*") 'font-lock-reference-face) - '("^\\(X-[A-Za-z0-9-]+\\|In-reply-to\\):.*" + '("^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):.*" . font-lock-string-face))) "Additional expressions to highlight in Message mode.") @@ -387,14 +577,34 @@ actually occur.") "Alist of mail and news faces for facemenu. The cdr of ech entry is a function for applying the face to a region.") -(defvar message-send-hook nil - "Hook run before sending messages.") +(defcustom message-send-hook nil + "Hook run before sending messages." + :group 'message + :options '(ispell-message) + :type 'hook) + +(defcustom message-send-mail-hook nil + "Hook run before sending mail messages." + :group 'message + :type 'hook) -(defvar message-sent-hook nil - "Hook run after sending messages.") +(defcustom message-send-news-hook nil + "Hook run before sending news messages." + :group 'message + :type 'hook) + +(defcustom message-sent-hook nil + "Hook run after sending messages." + :group 'message + :type 'hook) ;;; Internal variables. +(defvar message-buffer-list nil) + +;; Byte-compiler warning +(defvar gnus-active-hashtb) + ;;; Regexp matching the delimiter of messages in UNIX mail format ;;; (UNIX From lines), minus the initial ^. (defvar message-unix-mail-delimiter @@ -446,8 +656,8 @@ The cdr of ech entry is a function for applying the face to a region.") (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) @@ -458,13 +668,13 @@ The cdr of ech entry is a function for applying the face to a region.") (Lines) (Expires) (Message-ID) - (References . message-fill-header) + (References) (X-Mailer) (X-Newsreader)) "Alist used for formatting headers.") (eval-and-compile - (autoload 'message-setup-toolbar "message-xmas") + (autoload 'message-setup-toolbar "messagexmas") (autoload 'mh-send-letter "mh-comp")) @@ -489,6 +699,10 @@ The cdr of ech entry is a function for applying the face to a region.") (point) (goto-char p)))) +(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)) + ;; Delete the current line (and the next N lines.); (defmacro message-delete-line (&optional n) `(delete-region (progn (beginning-of-line) (point)) @@ -497,17 +711,36 @@ 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))) + (if (not header) + nil + (let ((regexp (format "[%s]+" (or separator ","))) + (beg 1) + (first t) + quoted elems paren) + (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) + (not paren)))) + (push (buffer-substring beg (point)) elems) + (setq beg (match-end 0))) + ((= (following-char) ?\") + (setq quoted (not quoted))) + ((and (= (following-char) ?\() + (not quoted)) + (setq paren t)) + ((and (= (following-char) ?\)) + (not quoted)) + (setq paren nil)))) + (nreverse elems))))) (defun message-fetch-field (header) "The same as `mail-fetch-field', only remove all newlines." @@ -633,7 +866,7 @@ Return the number of headers removed." (forward-char -1))) (lambda () (or (get-text-property (point) 'message-rank) - 0)))) + 10000)))) (defun message-sort-headers () "Sort the headers of the current message according to `message-header-format-alist'." @@ -701,32 +934,37 @@ Return the number of headers removed." (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] - ["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" news-reply-signature t] - ["Caesar (rot13) Message" message-caesar-buffer-body t] - ["Rename buffer" message-rename-buffer t] - "----" - ["Send Message" message-send-and-exit t] - ["Abort Message" message-dont-send t])) +(easy-menu-define + message-mode-menu message-mode-map "Message Menu." + '("Message" + ["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])) + +(easy-menu-define + message-mode-field-menu message-mode-map "" + '("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])) + +(defvar facemenu-add-face-function) +(defvar facemenu-remove-face-function) ;;;###autoload (defun message-mode () @@ -736,10 +974,10 @@ C-c C-s message-send (send the message) C-c C-c message-send-and-exit C-c C-f move to a header field (and create it if there isn't): C-c C-f C-t move to To C-c C-f C-s move to Subject C-c C-f C-c move to Cc C-c C-f C-b move to Bcc - C-c C-f C-f move to Fcc C-c C-f C-r move to Reply-To + 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-o move to 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) C-c C-b message-goto-body (move to beginning of message text). @@ -747,7 +985,7 @@ C-c C-i message-goto-signature (move to the beginning of the signature). C-c C-w message-insert-signature (insert `message-signature-file' file). C-c C-y message-yank-original (insert current message, if any). C-c C-q message-fill-yanked-message (fill what was yanked). -C-c C-r message-ceasar-buffer-body (rot13 the message body)." +C-c C-r message-caesar-buffer-body (rot13 the message body)." (interactive) (kill-all-local-variables) (make-local-variable 'message-reply-buffer) @@ -758,7 +996,7 @@ C-c C-r message-ceasar-buffer-body (rot13 the message body)." (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) @@ -778,9 +1016,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) @@ -791,8 +1031,8 @@ 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 (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) @@ -868,6 +1108,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)) @@ -875,15 +1116,22 @@ C-c C-r message-ceasar-buffer-body (rot13 the message body)." "Move point to the beginning of the message signature." (interactive) (goto-char (point-min)) - (or (re-search-forward message-signature-separator nil t) - (goto-char (point-max)))) + (if (re-search-forward message-signature-separator nil t) + (forward-line 1) + (goto-char (point-max)))) (defun message-insert-to () "Insert a To header that points to the author of the article being replied to." (interactive) - (when (message-position-on-field "To") + (let ((co (message-fetch-field "courtesy-copies-to"))) + (when (and co + (equal (downcase co) "never")) + (error "The user has requested not to have copies sent via mail"))) + (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") ""))) @@ -891,7 +1139,9 @@ C-c C-r message-ceasar-buffer-body (rot13 the message body)." (defun message-insert-newsgroups () "Insert the Newsgroups header from the article being replied to." (interactive) - (when (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") ""))) @@ -901,16 +1151,23 @@ 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) - force) - t) - ((message-functionp message-signature) - (funcall message-signature)) - ((listp message-signature) - (eval message-signature)) - (t message-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) + (funcall message-signature)) + ((listp message-signature) + (eval message-signature)) + (t message-signature))) (signature (cond ((stringp signature) signature) @@ -919,13 +1176,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") + (unless (bolp) + (insert "\n")) + (insert "\n-- \n") (if (eq signature t) (insert-file-contents message-signature-file) (insert signature)) @@ -1004,7 +1259,9 @@ name, rather than giving an automatic name." (name-default (concat "*message* " mail-trimmed-to)) (name (if enter-string (read-string "New buffer name: " name-default) - name-default))) + name-default)) + (default-directory + (file-name-as-directory message-autosave-directory))) (rename-buffer name t))))) (defun message-fill-yanked-message (&optional justifyp) @@ -1033,7 +1290,20 @@ However, if `message-yank-prefix' is non-nil, insert that prefix on each line." (if (search-forward "\n\n" nil t) (1- (point)) (point))) - (message-remove-header message-ignored-cited-headers t))) + (message-remove-header message-ignored-cited-headers t) + (goto-char (point-max)))) + ;; Delete blank lines at the start of the buffer. + (while (and (point-min) + (eolp) + (not (eobp))) + (message-delete-line)) + ;; Delete blank lines at the end of the buffer. + (goto-char (point-max)) + (unless (eolp) + (insert "\n")) + (while (and (zerop (forward-line -1)) + (looking-at "$")) + (message-delete-line)) ;; Do the indentation. (if (null message-yank-prefix) (indent-rigidly start (mark t) message-indentation-spaces) @@ -1050,6 +1320,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") @@ -1059,13 +1331,14 @@ 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 () +(defun message-cite-original () + "Cite function in the standard Message manner." (let ((start (point)) (functions (when message-indent-citation-function @@ -1119,21 +1392,21 @@ The text will also be indented the normal way." (save-excursion (let ((start (point)) mark) - (if (not (re-search-forward message-signature-separator (mark t) t)) - ;; No signature here, so we just indent the cited text. + (if (not (re-search-forward message-signature-separator (mark t) t)) + ;; No signature here, so we just indent the cited text. + (message-indent-citation) + ;; Find the last non-empty line. + (forward-line -1) + (while (looking-at "[ \t]*$") + (forward-line -1)) + (forward-line 1) + (setq mark (set-marker (make-marker) (point))) + (goto-char start) (message-indent-citation) - ;; Find the last non-empty line. - (forward-line -1) - (while (looking-at "[ \t]*$") - (forward-line -1)) - (forward-line 1) - (setq mark (set-marker (make-marker) (point))) - (goto-char start) - (message-indent-citation) - ;; Enable undoing the deletion. - (undo-boundary) - (delete-region mark (mark t)) - (set-marker mark nil))))) + ;; Enable undoing the deletion. + (undo-boundary) + (delete-region mark (mark t)) + (set-marker mark nil))))) @@ -1158,8 +1431,9 @@ The text will also be indented the normal way." (defun message-dont-send () "Don't send the message you have been editing." (interactive) - (message-bury (current-buffer)) - (message-do-actions message-postpone-actions)) + (let ((actions message-postpone-actions)) + (message-bury (current-buffer)) + (message-do-actions actions))) (defun message-kill-buffer () "Kill the current buffer." @@ -1194,6 +1468,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)) @@ -1207,18 +1484,27 @@ the user from the mailer." "Already sent message via mail; resend? ")) (message-send-mail arg)))) (message-do-fcc) - (when (fboundp 'mail-hist-put-headers-into-history) - (mail-hist-put-headers-into-history)) + ;;(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)) + ;; 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) @@ -1230,20 +1516,19 @@ the user from the mailer." "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)) + (ignore-errors + (cond + ;; A simple function. + ((message-functionp (car actions)) + (funcall (car actions))) + ;; Something to be evaled. + (t + (eval (car actions))))) (pop actions))) (defun message-send-mail (&optional arg) (require 'mail-utils) - (let ((tembuf (generate-new-buffer " message temp")) + (let ((tembuf (message-generate-new-buffer-clone-locals " message temp")) (case-fold-search nil) (news (message-news-p)) (mailbuf (current-buffer))) @@ -1259,7 +1544,11 @@ the user from the mailer." (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) @@ -1295,6 +1584,7 @@ the user from the mailer." (replace-match "\n") (backward-char 1) (setq delimline (point-marker)) + (run-hooks 'message-send-mail-hook) ;; Insert an extra newline if we need it to work around ;; Sun's bug that swallows newlines. (goto-char (1+ delimline)) @@ -1337,18 +1627,79 @@ the user from the mailer." (when (bufferp errbuf) (kill-buffer errbuf))))) +(defun message-send-mail-with-qmail () + "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 + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (run-hooks 'message-send-mail-hook) + ;; send the message + (case + (apply + 'call-process-region 1 (point-max) message-qmail-inject-program + nil nil nil + ;; qmail-inject's default behaviour is to look for addresses on the + ;; command line; if there're none, it scans the headers. + ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin. + ;; + ;; in general, ALL of qmail-inject's defaults are perfect for simply + ;; reading a formatted (i. e., at least a To: or Resent-To header) + ;; message from stdin. + ;; + ;; qmail also has the advantage of not having been raped by + ;; various vendors, so we don't have to allow for that, either -- + ;; compare this with message-send-mail-with-sendmail and weep + ;; for sendmail's lost innocence. + ;; + ;; all this is way cool coz it lets us keep the arguments entirely + ;; free for -inject-arguments -- a big win for the user and for us + ;; since we don't have to play that double-guessing game and the user + ;; gets full control (no gestapo'ish -f's, for instance). --sj + message-qmail-inject-args) + ;; qmail-inject doesn't say anything on it's stdout/stderr, + ;; we have to look at the retval instead + (0 nil) + (1 (error "qmail-inject reported permanent failure.")) + (111 (error "qmail-inject reported transient failure.")) + ;; should never happen + (t (error "qmail-inject reported unknown failure.")))) + (defun message-send-mail-with-mh () "Send the prepared message buffer with mh." - (let (mh-previous-window-config) + (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 wants to generate these headers itself. + (let ((headers message-deletable-headers)) + (while headers + (goto-char (point-min)) + ;;(message "Deleting header %s" (car headers)) (sit-for 5) + (and (re-search-forward + (concat "^" (symbol-name (car headers)) ": *") nil t) + (message-delete-line)) + (pop headers))) + (run-hooks 'message-send-mail-hook) + ;; Pass it on to mh. (mh-send-letter))) (defun message-send-news (&optional arg) - (let ((tembuf (generate-new-buffer " *message temp*")) + (let ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) (case-fold-search nil) (method (if (message-functionp message-post-method) (funcall message-post-method arg) message-post-method)) (messbuf (current-buffer)) + (message-syntax-checks + (if arg + (cons '(existing-newsgroups . disabled) + message-syntax-checks) + message-syntax-checks)) result) (save-restriction (message-narrow-to-headers) @@ -1356,13 +1707,21 @@ the user from the mailer." (message-generate-headers message-required-news-headers) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) - (when (message-check-news-syntax) + (message-cleanup-headers) + (if (not (message-check-news-syntax)) + (progn + ;;(message "Posting not performed") + nil) (unwind-protect (save-excursion (set-buffer tembuf) (buffer-disable-undo (current-buffer)) (erase-buffer) - (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) @@ -1373,12 +1732,13 @@ the user from the mailer." (or (= (preceding-char) ?\n) (insert ?\n)) (let ((case-fold-search t)) - ;; Remove the delimeter. + ;; 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)) @@ -1396,193 +1756,255 @@ the user from the mailer." ;;; Header generation & syntax checking. ;;; +(defmacro message-check (type &rest forms) + "Eval FORMS if TYPE is to be checked." + `(or (message-check-element ,type) + (save-excursion + ,@forms))) + +(put 'message-check 'lisp-indent-function 1) +(put 'message-check 'edebug-form-spec '(form body)) + +(defun message-check-element (type) + "Returns non-nil if this type is not to be checked." + (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me) + t + (let ((able (assq type message-syntax-checks))) + (and (consp able) + (eq (cdr able) 'disabled))))) + (defun message-check-news-syntax () "Check the syntax of the message." + (save-excursion + (save-restriction + (widen) + (and + ;; We narrow to the headers and check them first. + (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-check-news-header-syntax))) + ;; Check the body. + (message-check-news-body-syntax))))) + +(defun message-check-news-header-syntax () (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) + ;; Check for commands in Subject. + (message-check 'subject-cmsg + (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. + (message-check 'multiple-headers + (let (found) + (while (and (not found) + (re-search-forward "^[^ \t:]+: " nil t)) (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 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 From header. - (or (message-check-element 'from) - (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 + (or (re-search-forward + (concat "^" + (regexp-quote + (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. + (message-check 'sendsys + (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. + (message-check '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)) - (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? ")))) + (insert "Followup-To: " to "\n")) + t)) + ;; Check "Shoot me". + (message-check 'shoot + (if (re-search-forward + "Message-ID.*.i-did-not-set--mail-host-address--so-shoot-me" nil t) + (y-or-n-p "You appear to have a misconfigured system. Really post? ") + t)) + ;; Check for Approved. + (message-check 'approved + (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. + (message-check 'message-id + (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. + (message-check 'subject + (let* ((case-fold-search t) + (subject (message-fetch-field "subject"))) + (or + (and subject + (not (string-match "\\`[ \t]*\\'" subject))) + (ignore + (message + "The subject field is empty or missing. Posting is denied."))))) + ;; Check the Newsgroups & Followup-To headers. + (message-check '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. + (message-check '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. + (message-check 'from + (let* ((case-fold-search t) + (from (message-fetch-field "from")) + (ad (nth 1 (mail-extract-address-components from)))) + (cond + ((not from) + (message "There is no From line. Posting is denied.") + nil) + ((or (not (string-match "@[^\\.]*\\." ad)) ;larsi@ifi + (string-match "\\.\\." ad) ;larsi@ifi..uio + (string-match "@\\." ad) ;larsi@.ifi.uio + (string-match "\\.$" ad) ;larsi@ifi.uio. + (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio + (string-match "(.*).*(.*)" from)) ;(lars) (lars) + (message + "Denied posting -- the From looks strange: \"%s\"." from) + nil) + (t t)))))) + +(defun message-check-news-body-syntax () + (and + ;; Check for long lines. + (message-check 'long-lines + (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))) - (or (re-search-forward message-signature-separator nil t) - (goto-char (point-max))) - (beginning-of-line) - (or (re-search-backward "[^ \n\t]" b t) - (y-or-n-p "Empty article. Really post? "))))) + (message-check 'empty + (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))) + (message-check 'control-chars + (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)) + (message-check '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 (eq (message-checksum) message-checksum)) - (y-or-n-p - "It looks like no new text has been added. Really post? ")) + (message-check 'new-text + (or + (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 (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)))))) - -(defun message-check-element (type) - "Returns non-nil if this type is not to be checked." - (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me) - t - (let ((able (assq type message-syntax-checks))) - (and (consp able) - (eq (cdr able) 'disabled))))) + (message-check 'signature + (goto-char (point-max)) + (if (or (not (re-search-backward message-signature-separator nil t)) + (search-forward message-forward-end-separator nil t)) + t + (if (> (count-lines (point) (point-max)) 5) + (y-or-n-p + (format + "Your .sig is %d lines; it should be max 4. Really post? " + (1- (count-lines (point) (point-max))))) + t))))) (defun message-checksum () "Return a \"checksum\" for the current buffer." @@ -1592,7 +2014,8 @@ the user from the mailer." (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)) @@ -1620,7 +2043,8 @@ the user from the mailer." (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)) + 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)) @@ -1629,7 +2053,7 @@ the user from the mailer." (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) + (rmail-output file 1 nil t) (let ((mail-use-rfc822 t)) (rmail-output file 1 t t)))))) (kill-buffer (current-buffer))))) @@ -1685,7 +2109,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) @@ -1802,7 +2226,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 @@ -1848,7 +2275,7 @@ the user from the mailer." (goto-char fullname-start) (while (re-search-forward "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" - nil 1) + nil 1) (replace-match "\\1(\\3)" t) (goto-char fullname-start))) (insert ")"))) @@ -1870,34 +2297,37 @@ give as trustworthy answer as possible." (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 "@\\(.*\\)\\'" (message-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"))))) + (concat system-name ".i-did-not-set--mail-host-address--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. @@ -1931,7 +2361,7 @@ Headers already prepared in the buffer are not modified." (message-delete-line)) (pop headers))) ;; Go through all the required headers and see if they are in the - ;; articles already. If they are not, or are empty, they are + ;; articles already. If they are not, or are empty, they are ;; inserted automatically - except for Subject, Newsgroups and ;; Distribution. (while headers @@ -1946,7 +2376,7 @@ Headers already prepared in the buffer are not modified." (concat "^" (downcase (symbol-name header)) ":") nil t)) (progn - ;; The header was found. We insert a space after the + ;; The header was found. We insert a space after the ;; colon, if there is none. (if (/= (following-char) ? ) (insert " ") (forward-char 1)) ;; Find out whether the header is empty... @@ -2015,7 +2445,7 @@ Headers already prepared in the buffer are not modified." (downcase secure-sender))))) (goto-char (point-min)) ;; Rename any old Sender headers to Original-Sender. - (when (re-search-forward "^Sender:" nil t) + (when (re-search-forward "^\\(Original-\\)*Sender:" nil t) (beginning-of-line) (insert "Original-") (beginning-of-line)) @@ -2023,20 +2453,55 @@ Headers already prepared in the buffer are not modified." (defun message-insert-courtesy-copy () "Insert a courtesy message in mail copies of combined messages." - (save-excursion - (save-restriction - (message-narrow-to-headers) - (let ((newsgroups (message-fetch-field "newsgroups"))) - (when newsgroups + (let (newsgroups) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (when (setq newsgroups (message-fetch-field "newsgroups")) (goto-char (point-max)) - (insert "Posted-To: " newsgroups "\n")))) - (forward-line 1) - (insert message-courtesy-message))) + (insert "Posted-To: " newsgroups "\n"))) + (forward-line 1) + (when message-courtesy-message + (cond + ((string-match "%s" message-courtesy-message) + (insert (format message-courtesy-message newsgroups))) + (t + (insert message-courtesy-message))))))) ;;; ;;; 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) @@ -2077,24 +2542,73 @@ 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." - (if message-generate-new-buffers - (set-buffer (pop-to-buffer (generate-new-buffer name))) - (let ((buffer (get-buffer name))) - (if (and buffer - (buffer-name buffer)) - (progn - (set-buffer (pop-to-buffer buffer)) - (when (and (buffer-modified-p) - (not (y-or-n-p - "Message already being composed; erase? "))) - (error "Message being composed"))) - (set-buffer (pop-to-buffer name))))) + (let ((buffer (get-buffer name))) + (if (and buffer + (buffer-name buffer)) + (progn + (set-buffer (pop-to-buffer buffer)) + (when (and (buffer-modified-p) + (not (y-or-n-p + "Message already being composed; erase? "))) + (error "Message being composed"))) + (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) + (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) @@ -2109,10 +2623,15 @@ 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 (message-news-p) (when message-default-news-headers @@ -2130,6 +2649,7 @@ Headers already prepared in the buffer are not modified." (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 @@ -2168,14 +2688,14 @@ 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 ""))))) @@ -2186,13 +2706,10 @@ Headers already prepared in the buffer are not modified." (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) (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. (if (not wide) ;; This is a regular reply. @@ -2240,10 +2757,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))) @@ -2252,18 +2768,22 @@ 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))))) (setq follow-to (list (cons 'To (cdr (pop ccalist))))) (when ccalist - (push (cons 'Cc - (mapconcat (lambda (addr) (cdr addr)) ccalist ", ")) - follow-to))))) + (let ((ccs (cons 'Cc (mapconcat + (lambda (addr) (cdr addr)) ccalist ", ")))) + (when (string-match "^ +" (cdr ccs)) + (setcdr ccs (substring (cdr ccs) (match-end 0)))) + (push ccs follow-to)))))) (widen)) - (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 "")) @@ -2279,15 +2799,19 @@ Headers already prepared in the buffer are not modified." ;;;###autoload (defun message-wide-reply (&optional to-address) + "Make a \"wide\" reply to the message in the current buffer." (interactive) (message-reply to-address t)) ;;;###autoload -(defun message-followup () +(defun message-followup (&optional to-newsgroups) + "Follow up to the message in the current buffer. +If TO-NEWSGROUPS, use that as the new Newsgroups line." (interactive) (let ((cur (current-buffer)) 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 @@ -2322,11 +2846,13 @@ Headers already prepared in the buffer are not modified." (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) ,@(cond + (to-newsgroups + (list (cons 'Newsgroups to-newsgroups))) (follow-to follow-to) ((and followup-to message-use-followup-to) (list @@ -2359,15 +2885,16 @@ 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; +Also, some source/announcement newsgroups are not indented for discussion; responses here are directed to other newsgroups.")) (cons 'Newsgroups followup-to) (cons 'Newsgroups newsgroups)))))) (t `((Newsgroups . ,newsgroups)))) ,@(and distribution (list (cons 'Distribution distribution))) - (References . ,(concat (or references "") (and references " ") - (or message-id ""))) + ,@(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") @@ -2398,7 +2925,7 @@ responses here are directed to other newsgroups.")) distribution (message-fetch-field "distribution"))) ;; Make sure that this article was written by the user. (unless (string-equal - (downcase (mail-strip-quoted-names from)) + (downcase (cadr (mail-extract-address-components from))) (downcase (message-make-address))) (error "This article is not yours")) ;; Make control message. @@ -2413,7 +2940,7 @@ responses here are directed to other newsgroups.")) (concat "Distribution: " distribution "\n") "") mail-header-separator "\n" - "This is a cancel message from " from ".\n") + message-cancel-message) (message "Canceling your article...") (let ((message-syntax-checks 'dont-check-for-anything-just-trust-me)) (funcall message-send-news-function)) @@ -2429,11 +2956,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 (message-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. @@ -2470,7 +2998,8 @@ 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 "[" (or (message-fetch-field (if (message-news-p) "newsgroups" "from")) + (concat "[" (or (message-fetch-field + (if (message-news-p) "newsgroups" "from")) "(nowhere)") "] " (or (message-fetch-field "Subject") ""))) @@ -2480,24 +3009,28 @@ header line with the old Message-ID." Optional NEWS will use news to forward instead of mail." (interactive "P") (let ((cur (current-buffer)) - (subject (message-make-forward-subject))) + (subject (message-make-forward-subject)) + art-beg) (if news (message-news nil subject) (message-mail nil subject)) ;; Put point where we want it before inserting the forwarded ;; message. (if message-signature-before-forwarded-message (goto-char (point-max)) (message-goto-body)) + ;; Make sure we're at the start of the line. + (unless (eolp) + (insert "\n")) ;; Narrow to the area we are to insert. (narrow-to-region (point) (point)) ;; Insert the separators and the forwarded buffer. (insert message-forward-start-separator) + (setq art-beg (point)) (insert-buffer-substring cur) (goto-char (point-max)) (insert message-forward-end-separator) (set-text-properties (point-min) (point-max) nil) ;; Remove all unwanted headers. - (goto-char (point-min)) - (forward-line 1) + (goto-char art-beg) (narrow-to-region (point) (if (search-forward "\n\n" nil t) (1- (point)) (point))) @@ -2510,6 +3043,7 @@ Optional NEWS will use news to forward instead of mail." (defun message-resend (address) "Resend the current article to ADDRESS." (interactive "sResend message to: ") + (message "Resending message to %s..." address) (save-excursion (let ((cur (current-buffer)) beg) @@ -2545,7 +3079,8 @@ Optional NEWS will use news to forward instead of mail." (insert "Also-")) ;; Send it. (message-send-mail) - (kill-buffer (current-buffer))))) + (kill-buffer (current-buffer))) + (message "Resending message to %s...done" address))) ;;;###autoload (defun message-bounce () @@ -2556,7 +3091,7 @@ you." (interactive) (let ((cur (current-buffer)) boundary) - (message-pop-to-buffer "*mail message*") + (message-pop-to-buffer (message-buffer-name "bounce")) (insert-buffer-substring cur) (undo-boundary) (message-narrow-to-head) @@ -2579,7 +3114,7 @@ you." ;; 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 @@ -2602,7 +3137,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 @@ -2614,7 +3149,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 @@ -2626,7 +3161,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 ""))))) @@ -2639,7 +3174,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 ""))))) @@ -2655,13 +3190,13 @@ Called from program, takes two arguments START and END which specify the range to operate on." (interactive "r") (save-excursion - (let ((end1 (make-marker))) - (move-marker end1 (max start end)) - (goto-char (min start end)) - (while (< (point) end1) - (or (looking-at "[_\^@- ]") - (insert (following-char) "\b")) - (forward-char 1))))) + (let ((end1 (make-marker))) + (move-marker end1 (max start end)) + (goto-char (min start end)) + (while (< (point) end1) + (or (looking-at "[_\^@- ]") + (insert (following-char) "\b")) + (forward-char 1))))) ;;;###autoload (defun unbold-region (start end) @@ -2670,16 +3205,18 @@ Called from program, takes two arguments START and END which specify the range to operate on." (interactive "r") (save-excursion - (let ((end1 (make-marker))) - (move-marker end1 (max start end)) - (goto-char (min start end)) - (while (re-search-forward "\b" end1 t) - (if (eq (following-char) (char-after (- (point) 2))) - (delete-char -2)))))) + (let ((end1 (make-marker))) + (move-marker end1 (max start end)) + (goto-char (min start end)) + (while (re-search-forward "\b" end1 t) + (if (eq (following-char) (char-after (- (point) 2))) + (delete-char -2)))))) + +(defalias 'message-exchange-point-and-mark 'exchange-point-and-mark) ;; Support for toolbar (when (string-match "XEmacs\\|Lucid" emacs-version) - (require 'message-xmas)) + (require 'messagexmas)) ;;; Group name completion. @@ -2722,18 +3259,15 @@ Do a `tab-to-tab-stop' if not in those headers." (message "No matching groups") (pop-to-buffer "*Completions*") (buffer-disable-undo (current-buffer)) - (erase-buffer) - (let ((standard-output (current-buffer))) - (display-completion-list (sort completions 'string<))) - (goto-char (point-min)) - (pop-to-buffer cur)))))) + (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 temporary buffer." - `(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." @@ -2748,15 +3282,36 @@ The following arguments may contain lists of values." (funcall ask question)) (funcall ask question))) -(defun message-flatten-list (&rest list) - (message-flatten-list-1 list)) +(defun message-flatten-list (list) + "Return a new, flat list that contains all elements of LIST. -(defun message-flatten-list-1 (list) +\(message-flatten-list '(1 (2 3 (4 5 (6))) 7)) +=> (1 2 3 4 5 6 7)" (cond ((consp list) - (apply 'append (mapcar 'message-flatten-list-1 list))) + (apply 'append (mapcar 'message-flatten-list list))) (list (list list)))) +(defun message-generate-new-buffer-clone-locals (name &optional varstr) + "Create and return a buffer with a name based on NAME using generate-new-buffer. +Then clone the local variables and values from the old buffer to the +new one, cloning only the locals having a substring matching the +regexp varstr." + (let ((oldlocals (buffer-local-variables))) + (save-excursion + (set-buffer (generate-new-buffer name)) + (mapcar (lambda (dude) + (when (and (car dude) + (or (not varstr) + (string-match varstr (symbol-name (car dude))))) + (ignore-errors + (set (make-local-variable (car dude)) + (cdr dude))))) + oldlocals) + (current-buffer)))) + +(run-hooks 'message-load-hook) + (provide 'message) ;;; message.el ends here