X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=1b3994803595df6e93399e8a7b31b1fb8826425e;hb=b19ab0bcf7b463d4b14b41bd23f2a5d62d03795a;hp=5e44235627edad579193aaf40c7ee18c5170e792;hpb=676c4fb87fc9b18b87edd03b077a2ef263d21a71;p=gnus diff --git a/lisp/message.el b/lisp/message.el index 5e4423562..1b3994803 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -31,10 +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 @@ -99,7 +112,7 @@ 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) +(defvar message-deletable-headers '(Message-ID Date Lines) "*Headers to be deleted if they already exist and were generated by message previously.") ;;;###autoload @@ -112,8 +125,7 @@ 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.") @@ -128,15 +140,17 @@ any confusion.") 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.") +(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) -;;;###autoload (defvar message-user-organization (or (and (boundp 'gnus-local-organization) gnus-local-organization) @@ -149,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.") @@ -179,18 +193,24 @@ If nil, message won't autosave.") (defvar message-ignored-cited-headers "." "Delete these headers from the messages you yank.") +(defvar message-cancel-message "I am canceling my own article." + "Message to be inserted in the cancel message.") + ;; 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-sendmail' (the default), +`message-send-mail-with-mh' and `message-send-mail-with-qmail'.") ;;;###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 @@ -218,6 +238,18 @@ 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.") +;; qmail-related stuff +(defvar message-qmail-inject-program "/var/qmail/bin/qmail-inject" + "Location of the qmail-inject program.") + +(defvar 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\").") + (defvar gnus-post-method) (defvar gnus-select-method) ;;;###autoload @@ -234,14 +266,21 @@ always use 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.") - (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.") @@ -300,6 +339,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 @@ -340,12 +385,19 @@ these lines.") The value should be an expression to test whether the problem will actually occur.") +;;; Internal variables. +;;; Well, not really internal. + (defvar message-mode-syntax-table (let ((table (copy-syntax-table text-mode-syntax-table))) (modify-syntax-entry ?% ". " table) 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) @@ -379,6 +431,11 @@ The cdr of ech entry is a function for applying the face to a region.") ;;; 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 @@ -430,8 +487,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) @@ -448,7 +505,8 @@ The cdr of ech entry is a function for applying the face to a region.") "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")) @@ -472,6 +530,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)) @@ -480,17 +542,40 @@ 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 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." + (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." @@ -498,7 +583,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*") @@ -580,16 +665,16 @@ 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." @@ -610,7 +695,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'." @@ -620,7 +705,7 @@ Return the number of headers removed." (let ((max (1+ (length message-header-format-alist))) rank) (message-narrow-to-headers) - (while (re-search-forward "^[^ ]+:" nil t) + (while (re-search-forward "^[^ \n]+:" nil t) (put-text-property (match-beginning 0) (1+ (match-beginning 0)) 'message-rank @@ -669,23 +754,29 @@ Return the number of headers removed." (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) - (define-key message-mode-map "\C-c\C-k" 'message-dont-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] - ["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] + ["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] "----" @@ -694,12 +785,17 @@ Return the number of headers removed." ["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] + ["Insert Signature" message-insert-signature t] ["Caesar (rot13) Message" message-caesar-buffer-body t] + ["Rename buffer" message-rename-buffer t] + ["Spellcheck" ispell-message t] "----" - ["Post Message" message-send-and-exit 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 () "Major mode for editing mail and news to be sent. @@ -725,9 +821,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) @@ -747,9 +846,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) @@ -760,11 +861,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 (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)) @@ -833,6 +938,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)) @@ -848,7 +954,9 @@ 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) - (when (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") ""))) @@ -856,7 +964,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") ""))) @@ -866,9 +976,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) @@ -884,13 +1000,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)) @@ -950,6 +1064,30 @@ 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)) + (default-directory + (file-name-as-directory message-autosave-directory))) + (rename-buffer name t))))) + (defun message-fill-yanked-message (&optional justifyp) "Fill the paragraphs of a message yanked into this one. Numeric argument means justify as well." @@ -976,7 +1114,19 @@ 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)) + (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) @@ -993,6 +1143,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") @@ -1002,13 +1154,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 @@ -1087,19 +1240,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)) (if message-kill-buffer-on-exit (kill-buffer buf) (bury-buffer buf) (when (eq buf (current-buffer)) - (message-bury buf)))))) + (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." @@ -1127,6 +1290,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)) @@ -1138,48 +1304,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)) + ;;(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 delimline (mailbuf (current-buffer))) (save-restriction (message-narrow-to-headers) - (setq resend-to-addresses (mail-fetch-field "resent-to")) ;; 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) @@ -1190,82 +1382,164 @@ 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)) - ;; 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))))))) - (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-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") + ;; 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 being 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 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))) + ;; Pass it on to mh. + (mh-send-letter))) + (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) @@ -1285,11 +1559,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. @@ -1307,7 +1585,7 @@ the user from the mailer." (or (message-check-element 'subject-cmsg) (save-excursion - (if (string-match "^cmsg " (mail-fetch-field "subject")) + (if (string-match "^cmsg " (message-fetch-field "subject")) (y-or-n-p "The control code \"cmsg \" is in the subject. Really post? ") t))) @@ -1340,8 +1618,8 @@ the user from the mailer." 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")) + (let ((newsgroups (message-fetch-field "newsgroups")) + (followup-to (message-fetch-field "followup-to")) to) (when (and newsgroups (string-match "," newsgroups) (not followup-to) @@ -1357,7 +1635,15 @@ the user from the mailer." (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 @@ -1369,7 +1655,7 @@ the user from the mailer." (or (message-check-element 'message-id) (save-excursion (let* ((case-fold-search t) - (message-id (mail-fetch-field "message-id"))) + (message-id (message-fetch-field "message-id"))) (or (not message-id) (and (string-match "@" message-id) (string-match "@[^\\.]*\\." message-id)) @@ -1382,7 +1668,7 @@ the user from the mailer." (message-check-element 'subject) (save-excursion (let* ((case-fold-search t) - (subject (mail-fetch-field "subject"))) + (subject (message-fetch-field "subject"))) (or (and subject (not (string-match "\\`[ \t]*\\'" subject))) @@ -1390,30 +1676,83 @@ the user from the mailer." (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 (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)))))))) + (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 @@ -1437,8 +1776,8 @@ the user from the mailer." (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))) + (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? "))))) @@ -1459,26 +1798,29 @@ the user from the mailer." ;; Check whether any new text has been added. (or (message-check-element 'new-text) (not message-checksum) - (not (eq (message-checksum) 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)))))) + (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 + "Your .sig is %d lines; it should be max 4. Really post? " + (1- (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) - nil + t (let ((able (assq type message-syntax-checks))) (and (consp able) (eq (cdr able) 'disabled))))) @@ -1491,7 +1833,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)) @@ -1507,7 +1850,7 @@ the user from the mailer." (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))) (goto-char (point-min)) @@ -1519,7 +1862,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)) @@ -1573,7 +1917,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) @@ -1584,7 +1928,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) @@ -1701,7 +2045,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 @@ -1769,34 +2116,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"))))) (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. @@ -1815,7 +2165,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) @@ -1897,8 +2247,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)) @@ -1925,7 +2275,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")))) @@ -1936,6 +2286,36 @@ 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) @@ -1976,25 +2356,75 @@ 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) - (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. @@ -2007,10 +2437,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 @@ -2028,15 +2463,12 @@ 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 (message-narrow-to-headers) (run-hooks 'message-header-setup-hook)) - ;; Allow mail alias things. - (if (fboundp 'mail-abbrevs-setup) - (mail-abbrevs-setup) - (funcall (intern "mail-aliases-setup"))) (set-buffer-modified-p nil) (run-hooks 'message-setup-hook) (message-position-point) @@ -2070,14 +2502,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 ""))))) @@ -2088,13 +2520,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. @@ -2106,22 +2535,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") - 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 (unless ignore-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))) @@ -2142,10 +2571,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))) @@ -2154,7 +2582,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))))) @@ -2165,7 +2593,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 "")) @@ -2190,6 +2620,7 @@ Headers already prepared in the buffer are not modified." (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 @@ -2200,17 +2631,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. @@ -2219,12 +2650,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) @@ -2235,14 +2666,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 @@ -2268,39 +2719,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 'dont-check-for-anything-just-trust-me)) - (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" + message-cancel-message) + (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 () @@ -2311,11 +2762,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. @@ -2352,8 +2804,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) @@ -2361,24 +2814,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))) @@ -2425,7 +2882,7 @@ 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 @@ -2437,12 +2894,12 @@ 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) - (if (and (mail-fetch-field "Mime-Version") - (setq boundary (mail-fetch-field "Content-Type"))) + (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")) @@ -2460,7 +2917,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 @@ -2483,7 +2940,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 @@ -2495,7 +2952,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 @@ -2507,7 +2964,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 ""))))) @@ -2520,7 +2977,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 ""))))) @@ -2558,9 +3015,86 @@ 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 'message-xmas)) + (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. + +(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)