(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.")
;;;###autoload
(defvar message-fcc-handler-function 'rmail-output
"*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.")
;; Useful to set in site-init.el
;;;###autoload
-(defvar message-send-mail-function 'message-send-mail
+(defvar message-send-mail-function 'message-send-mail-with-sendmail
"Function to call to send the current buffer as mail.
The headers should be delimited by a line whose contents match the
-variable `mail-header-separator'.")
+variable `mail-header-separator'.
+
+Legal values include `message-send-mail-with-mh' and
+`message-send-mail-with-sendmail', which is the default.")
;;;###autoload
(defvar message-send-news-function 'message-send-news
"Normal hook, run each time a new outgoing message is initialized.
The function `message-setup' runs this hook.")
+(defvar message-mode-hook nil
+ "Hook run in message mode buffers.")
+
(defvar message-header-setup-hook nil
"Hook called narrowed to the headers when setting up a message buffer.")
(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
"Alist used for formatting headers.")
(eval-and-compile
- (autoload 'message-setup-toolbar "message-xmas"))
+ (autoload 'message-setup-toolbar "message-xmas")
+ (autoload 'mh-send-letter "mh-comp"))
\f
(setq beg (match-end 0)))
(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."
(when (and message-reply-buffer
(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*")
(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."
(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
(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]
"----"
["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]
+ ["Spellcheck" ispell-message t]
"----"
- ["Post Message" message-send-and-exit t]
+ ["Send Message" message-send-and-exit t]
["Abort Message" message-dont-send t]))
;;;###autoload
(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)
(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))
\f
(narrow-to-region (point) (point-max)))
(message-caesar-region (point-min) (point-max) rotnum))))
+(defun message-rename-buffer (&optional enter-string)
+ "Rename the *message* buffer to \"*message* RECIPIENT\".
+If the function is run with a prefix, it will ask for a new buffer
+name, rather than giving an automatic name."
+ (interactive "Pbuffer name: ")
+ (save-excursion
+ (save-restriction
+ (goto-char (point-min))
+ (narrow-to-region (point)
+ (search-forward mail-header-separator nil 'end))
+ (let* ((mail-to (if (message-news-p) (message-fetch-field "Newsgroups")
+ (message-fetch-field "To")))
+ (mail-trimmed-to
+ (if (string-match "," mail-to)
+ (concat (substring mail-to 0 (match-beginning 0)) ", ...")
+ mail-to))
+ (name-default (concat "*message* " mail-trimmed-to))
+ (name (if enter-string
+ (read-string "New buffer name: " name-default)
+ name-default)))
+ (rename-buffer name t)))))
+
(defun message-fill-yanked-message (&optional justifyp)
"Fill the paragraphs of a message yanked into this one.
Numeric argument means justify as well."
(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."
(y-or-n-p "No changes in the buffer; really send? ")))
;; Make it possible to undo the coming changes.
(undo-boundary)
+ (message-fix-before-sending)
(run-hooks 'message-send-hook)
(message "Sending...")
(when (and (or (not (message-news-p))
(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))
(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)))
+ (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
(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-mh ()
+ "Send the prepared message buffer with mh."
+ (let ((mh-previous-window-config nil)
+ (name (make-temp-name
+ (concat (file-name-as-directory message-autosave-directory)
+ "msg."))))
+ (setq buffer-file-name name)
+ (mh-send-letter)
+ (condition-case ()
+ (delete-file name)
+ (error nil))))
+
(defun message-send-news (&optional arg)
(let ((tembuf (generate-new-buffer " *message temp*"))
(case-fold-search nil)
(method (if (message-functionp message-post-method)
(funcall message-post-method arg)
message-post-method))
- (messbuf (current-buffer)))
+ (messbuf (current-buffer))
+ result)
(save-restriction
(message-narrow-to-headers)
;; Insert some headers.
(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.
(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)))
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)
(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))
(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)))
(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
+ (unless (boundp (intern (car groups) hashtb))
+ (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
+ (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
(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 "^-- $" 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? "
+ (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)))))
(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))
(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)
(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)
(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))
(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"))))
(message-mode))
(defun message-setup (headers &optional replybuffer actions)
- (setq message-send-actions actions)
+ (when actions
+ (setq message-send-actions actions))
(setq message-reply-buffer replybuffer)
(goto-char (point-min))
;; Insert all the headers.
(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)
(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)))
(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.
(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))
(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
(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 (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)))))
;;;###autoload
(defun message-supersede ()
(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-fetch-field "from")))
(downcase (mail-strip-quoted-names (message-make-address))))
(error "This article is not yours"))
;; Get a normal message buffer.
(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)
(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.
(beginning-of-line)
(insert "Also-"))
;; Send it.
- (funcall message-send-mail-function)
+ (message-send-mail)
(kill-buffer (current-buffer)))))
;;;###autoload
(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"))
(when (string-match "XEmacs\\|Lucid" emacs-version)
(require 'message-xmas))
+;;; Group name completion.
+
+(defvar message-newgroups-header-regexp
+ "^\\(Newsgroups\\|Followup-To\\|Posted-To\\):"
+ "Regexp that match headers that lists groups.")
+
+(defun message-tab ()
+ "Expand group names in Newsgroups and Followup-To headers.
+Do a `tab-to-tab-stop' if not in those headers."
+ (interactive)
+ (if (let ((mail-abbrev-mode-regexp message-newgroups-header-regexp))
+ (mail-abbrev-in-expansion-header-p))
+ (message-expand-group)
+ (tab-to-tab-stop)))
+
+(defvar gnus-active-hashtb)
+(defun message-expand-group ()
+ (let* ((b (save-excursion (skip-chars-backward "^, :\t\n") (point)))
+ (completion-ignore-case t)
+ (string (buffer-substring b (point)))
+ (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))
+ (completions (all-completions string hashtb))
+ (cur (current-buffer))
+ comp)
+ (delete-region b (point))
+ (cond
+ ((= (length completions) 1)
+ (if (string= (car completions) string)
+ (progn
+ (insert string)
+ (message "Only matching group"))
+ (insert (car completions))))
+ ((and (setq comp (try-completion string hashtb))
+ (not (string= comp string)))
+ (insert comp))
+ (t
+ (insert string)
+ (if (not comp)
+ (message "No matching groups")
+ (pop-to-buffer "*Completions*")
+ (buffer-disable-undo (current-buffer))
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (let ((standard-output (current-buffer)))
+ (display-completion-list (sort completions 'string<)))
+ (goto-char (point-min))
+ (pop-to-buffer cur)))))))
+
+;;; Help stuff.
+
+(defmacro message-y-or-n-p (question show &rest text)
+ "Ask QUESTION, displaying the rest of the arguments in a 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."
+ (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))))
+
(provide 'message)
;;; message.el ends here
projects / gnus / blobdiff