;;; message.el --- composing mail and news messages
-;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000
+;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: mail, news
;;; Code:
(eval-when-compile (require 'cl))
-
(require 'mailheader)
(require 'nnheader)
(require 'easymenu)
-(require 'custom)
(if (string-match "XEmacs\\|Lucid" emacs-version)
(require 'mail-abbrevs)
(require 'mailabbrev))
:group 'message-headers)
(defcustom message-syntax-checks nil
- ; Guess this one shouldn't be easy to customize...
+ ;; Guess this one shouldn't be easy to customize...
"*Controls what syntax checks should not be performed on outgoing posts.
To disable checking of long signatures, for instance, add
`(signature . disabled)' to this list.
(defcustom message-make-forward-subject-function
'message-forward-subject-author-subject
- "*A list of functions that are called to generate a subject header for forwarded messages.
+ "*A list of functions that are called to generate a subject header for forwarded messages.
The subject generated by the previous function is passed into each
successive function.
newsgroup)), in brackets followed by the subject
* message-forward-subject-fwd (Subject of article with 'Fwd:' prepended
to it."
- :group 'message-forwarding
- :type '(radio (function-item message-forward-subject-author-subject)
- (function-item message-forward-subject-fwd)))
+ :group 'message-forwarding
+ :type '(radio (function-item message-forward-subject-author-subject)
+ (function-item message-forward-subject-fwd)))
(defcustom message-forward-as-mime t
"*If non-nil, forward messages as an inline/rfc822 MIME section. Otherwise, directly inline the old message in the forwarded message."
:group 'message-forwarding
:type 'boolean)
+(defcustom message-forward-before-signature t
+ "*If non-nil, put forwarded message before signature, else after."
+ :group 'message-forwarding
+ :type 'boolean)
+
(defcustom message-wash-forwarded-subjects nil
"*If non-nil, try to remove as much old cruft as possible from the subject of messages before generating the new subject of a forward."
:group 'message-forwarding
:group 'message-interface
:type 'regexp)
-(defcustom message-forward-ignored-headers nil
+(defcustom message-forward-ignored-headers "Content-Transfer-Encoding"
"*All headers that match this regexp will be deleted when forwarding a message."
:group 'message-forwarding
:type '(choice (const :tag "None" nil)
:group 'message-insertion
:type 'regexp)
-(defcustom message-cancel-message "I am canceling my own article."
+(defcustom message-cancel-message "I am canceling my own article.\n"
"Message to be inserted in the cancel message."
:group 'message-interface
:type 'string)
:type 'message-header-lines)
(defcustom message-default-news-headers ""
- "*A string of header lines to be inserted in outgoing news
-articles."
+ "*A string of header lines to be inserted in outgoing news articles."
:group 'message-headers
:group 'message-news
:type 'message-header-lines)
"\\([^\0-\b\n-\r\^?].*\\)? "
;; The time the message was sent.
- "\\([^\0-\r \^?]+\\) +" ; day of the week
- "\\([^\0-\r \^?]+\\) +" ; month
- "\\([0-3]?[0-9]\\) +" ; day of month
- "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day
+ "\\([^\0-\r \^?]+\\) +" ; day of the week
+ "\\([^\0-\r \^?]+\\) +" ; month
+ "\\([0-3]?[0-9]\\) +" ; day of month
+ "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day
;; Perhaps a time zone, specified by an abbreviation, or by a
;; numeric offset.
(defun message-fetch-field (header &optional not-all)
"The same as `mail-fetch-field', only remove all newlines."
(let* ((inhibit-point-motion-hooks t)
+ (case-fold-search t)
(value (mail-fetch-field header nil (not not-all))))
(when value
(while (string-match "\n[\t ]+" value)
(unless (string-match "^\\([^:]+\\):[ \t]*[^ \t]" (car headers))
(error "Invalid header `%s'" (car headers)))
(setq hclean (match-string 1 (car headers)))
- (save-restriction
- (message-narrow-to-headers)
- (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t)
- (insert (car headers) ?\n))))
+ (save-restriction
+ (message-narrow-to-headers)
+ (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t)
+ (insert (car headers) ?\n))))
(setq headers (cdr headers))))
(setq adaptive-fill-first-line-regexp
(concat "[ \t]*[-a-z0-9A-Z]*\\(>[ \t]*\\)+[ \t]*\\|"
adaptive-fill-first-line-regexp))
+ (make-local-variable 'auto-fill-inhibit-regexp)
+ (setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:")
(mm-enable-multibyte)
(make-local-variable 'indent-tabs-mode) ;Turn off tabs for indentation.
(setq indent-tabs-mode nil)
(insert (or (message-fetch-reply-field "reply-to")
(message-fetch-reply-field "from") "")))
+(defun message-widen-reply ()
+ "Widen the reply to include maximum recipients."
+ (interactive)
+ (let ((follow-to
+ (and message-reply-buffer
+ (buffer-name message-reply-buffer)
+ (save-excursion
+ (set-buffer message-reply-buffer)
+ (message-get-reply-headers t)))))
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (dolist (elem follow-to)
+ (message-remove-header (symbol-name (car elem)))
+ (goto-char (point-min))
+ (insert (symbol-name (car elem)) ": "
+ (cdr elem) "\n"))))))
+
(defun message-insert-newsgroups ()
"Insert the Newsgroups header from the article being replied to."
(interactive)
;; We build the table, if necessary.
(when (or (not message-caesar-translation-table)
(/= (aref message-caesar-translation-table ?a) (+ ?a n)))
- (setq message-caesar-translation-table
- (message-make-caesar-translation-table n)))
- ;; Then we translate the region. Do it this way to retain
- ;; text properties.
- (while (< b e)
- (when (< (char-after b) 255)
- (subst-char-in-region
- b (1+ b) (char-after b)
- (aref message-caesar-translation-table (char-after b))))
- (incf b))))
+ (setq message-caesar-translation-table
+ (message-make-caesar-translation-table n)))
+ (translate-region b e message-caesar-translation-table)))
(defun message-make-caesar-translation-table (n)
"Create a rot table with offset N."
(save-restriction
(when (message-goto-body)
(narrow-to-region (point) (point-max)))
- (let ((body (buffer-substring (point-min) (point-max))))
- (unless (equal 0 (call-process-region
- (point-min) (point-max) program t t))
- (insert body)
- (message "%s failed" program))))))
+ (shell-command-on-region
+ (point-min) (point-max) program nil t))))
(defun message-rename-buffer (&optional enter-string)
"Rename the *message* buffer to \"*message* RECIPIENT\".
message-indent-citation-function
(list message-indent-citation-function)))))
(mml-quote-region start end)
+ ;; Allow undoing.
+ (undo-boundary)
(goto-char end)
(when (re-search-backward message-signature-separator start t)
;; Also peel off any blank lines before the signature.
(defun message-send (&optional arg)
"Send the message in the current buffer.
-If `message-interactive' is non-nil, wait for success indication
-or error messages, and inform user.
-Otherwise any failure is reported in a message back to
-the user from the mailer."
+If `message-interactive' is non-nil, wait for success indication or
+error messages, and inform user.
+Otherwise any failure is reported in a message back to the user from
+the mailer.
+The usage of ARG is defined by the instance that called Message.
+It should typically alter the sending method in some way or other."
(interactive "P")
;; Make it possible to undo the coming changes.
(undo-boundary)
(defun message-send-mail (&optional arg)
(require 'mail-utils)
- (let ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
- (case-fold-search nil)
- (news (message-news-p))
- (mailbuf (current-buffer)))
+ (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
+ (case-fold-search nil)
+ (news (message-news-p))
+ (mailbuf (current-buffer))
+ (message-this-is-mail t)
+ (message-posting-charset
+ (if (fboundp 'gnus-setup-posting-charset)
+ (gnus-setup-posting-charset nil)
+ message-posting-charset)))
(save-restriction
(message-narrow-to-headers)
;; Insert some headers.
(defun message-send-mail-with-sendmail ()
"Send off the prepared buffer with sendmail."
(let ((errbuf (if message-interactive
- (message-generate-new-buffer-clone-locals " sendmail errors")
+ (message-generate-new-buffer-clone-locals
+ " sendmail errors")
0))
resend-to-addresses delimline)
(let ((case-fold-search t))
(mh-send-letter)))
(defun message-send-news (&optional arg)
- (let ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
- (case-fold-search nil)
- (method (if (message-functionp message-post-method)
- (funcall message-post-method arg)
- message-post-method))
- (messbuf (current-buffer))
- (message-syntax-checks
- (if arg
- (cons '(existing-newsgroups . disabled)
- message-syntax-checks)
- message-syntax-checks))
- result)
+ (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
+ (case-fold-search nil)
+ (method (if (message-functionp message-post-method)
+ (funcall message-post-method arg)
+ message-post-method))
+ (messbuf (current-buffer))
+ (message-syntax-checks
+ (if arg
+ (cons '(existing-newsgroups . disabled)
+ message-syntax-checks)
+ message-syntax-checks))
+ (message-this-is-news t)
+ (message-posting-charset (gnus-setup-posting-charset
+ (message-fetch-field "Newsgroups")))
+ result)
(if (not (message-check-news-body-syntax))
nil
(save-restriction
(message-generate-headers '(Lines)))
;; Remove some headers.
(message-remove-header message-ignored-news-headers t)
- (let ((mail-parse-charset message-posting-charset))
+ (let ((mail-parse-charset (car message-posting-charset)))
(mail-encode-encoded-word-buffer)))
(goto-char (point-max))
;; require one newline at the end.
(backward-char 1))
(run-hooks 'message-send-news-hook)
(gnus-open-server method)
- (setq result (let ((mail-header-separator ""))
- (gnus-request-post method))))
+ (setq result (let ((mail-header-separator ""))
+ (gnus-request-post method))))
(kill-buffer tembuf))
(set-buffer messbuf)
(if result
(defun message-check-news-header-syntax ()
(and
;; Check Newsgroups header.
- (message-check 'newsgroyps
+ (message-check 'newsgroups
(let ((group (message-fetch-field "newsgroups")))
(or
(and group
"Make an Organization header."
(let* ((organization
(when message-user-organization
- (if (message-functionp message-user-organization)
- (funcall message-user-organization)
- message-user-organization))))
+ (if (message-functionp message-user-organization)
+ (funcall message-user-organization)
+ message-user-organization))))
(save-excursion
(message-set-work-buffer)
(cond ((stringp organization)
;; The element is a symbol. We insert the value
;; of this symbol, if any.
(symbol-value header))
- (t
+ ((not (message-check-element header))
;; We couldn't generate a value for this header,
;; so we just ask the user.
(read-from-minibuffer
;; If folding is disallowed, make sure the total length (including
;; the spaces between) will be less than MAXSIZE characters.
- (when message-cater-to-broken-inn
+ ;;
+ ;; Only disallow folding for News messages. At this point the headers
+ ;; have not been generated, thus we use message-this-is-news directly.
+ (when (and message-this-is-news message-cater-to-broken-inn)
(let ((maxsize 988)
(totalsize (+ (apply #'+ (mapcar #'length refs))
(1- count)))
;; Finally, collect the references back into a string and insert
;; it into the buffer.
(let ((refstring (mapconcat #'identity refs " ")))
- (if message-cater-to-broken-inn
+ (if (and message-this-is-news message-cater-to-broken-inn)
(insert (capitalize (symbol-name header)) ": "
refstring "\n")
(message-fill-header header refstring)))))
(message-setup `((Newsgroups . ,(or newsgroups ""))
(Subject . ,(or subject ""))))))
+(defun message-get-reply-headers (wide &optional to-address)
+ (let (follow-to mct never-mct from to cc reply-to ccalist)
+ ;; Find all relevant headers we need.
+ (setq from (message-fetch-field "from")
+ to (message-fetch-field "to")
+ cc (message-fetch-field "cc")
+ mct (message-fetch-field "mail-copies-to")
+ reply-to (message-fetch-field "reply-to"))
+
+ ;; Handle special values of Mail-Copies-To.
+ (when mct
+ (cond ((or (equal (downcase mct) "never")
+ (equal (downcase mct) "nobody"))
+ (setq never-mct t)
+ (setq mct nil))
+ ((or (equal (downcase mct) "always")
+ (equal (downcase mct) "poster"))
+ (setq mct (or reply-to from)))))
+
+ (if (or (not wide)
+ to-address)
+ (progn
+ (setq follow-to (list (cons 'To (or to-address reply-to from))))
+ (when (and wide mct)
+ (push (cons 'Cc mct) follow-to)))
+ (let (ccalist)
+ (save-excursion
+ (message-set-work-buffer)
+ (unless never-mct
+ (insert (or reply-to from "")))
+ (insert (if to (concat (if (bolp) "" ", ") to "") ""))
+ (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
+ (insert (if cc (concat (if (bolp) "" ", ") cc) ""))
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t]+" nil t)
+ (replace-match " " t t))
+ ;; Remove addresses that match `rmail-dont-reply-to-names'.
+ (let ((rmail-dont-reply-to-names message-dont-reply-to-names))
+ (insert (prog1 (rmail-dont-reply-to (buffer-string))
+ (erase-buffer))))
+ (goto-char (point-min))
+ ;; Perhaps "Mail-Copies-To: never" removed the only address?
+ (when (eobp)
+ (insert (or reply-to from "")))
+ (setq ccalist
+ (mapcar
+ (lambda (addr)
+ (cons (mail-strip-quoted-names addr) addr))
+ (message-tokenize-header (buffer-string))))
+ (let ((s ccalist))
+ (while s
+ (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
+ (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
+ (when ccalist
+ (let ((ccs (cons 'Cc (mapconcat
+ (lambda (addr) (cdr addr)) ccalist ", "))))
+ (when (string-match "^ +" (cdr ccs))
+ (setcdr ccs (substring (cdr ccs) (match-end 0))))
+ (push ccs follow-to)))))
+ follow-to))
+
+
;;;###autoload
(defun message-reply (&optional to-address wide)
"Start editing a reply to the article in the current buffer."
references message-id follow-to
(inhibit-point-motion-hooks t)
(message-this-is-mail t)
- mct never-mct gnus-warning)
+ gnus-warning)
(save-restriction
(message-narrow-to-head)
;; Allow customizations to have their say.
(save-excursion
(setq follow-to
(funcall message-wide-reply-to-function)))))
- ;; Find all relevant headers we need.
- (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 (message-fetch-field "reply-to")
+ (setq message-id (message-fetch-field "message-id" t)
references (message-fetch-field "references")
- message-id (message-fetch-field "message-id" t))
- ;; Remove any (buggy) Re:'s that are present and make a
- ;; proper one.
- (when (string-match message-subject-re-regexp subject)
- (setq subject (substring subject (match-end 0))))
- (setq subject (concat "Re: " subject))
-
- (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
- (string-match "<[^>]+>" gnus-warning))
- (setq message-id (match-string 0 gnus-warning)))
-
- ;; Handle special values of Mail-Copies-To.
- (when mct
- (cond ((or (equal (downcase mct) "never")
- (equal (downcase mct) "nobody"))
- (setq never-mct t)
- (setq mct nil))
- ((or (equal (downcase mct) "always")
- (equal (downcase mct) "poster"))
- (setq mct (or reply-to from)))))
-
- (unless follow-to
- (if (or (not wide)
- to-address)
- (progn
- (setq follow-to (list (cons 'To (or to-address reply-to from))))
- (when (and wide mct)
- (push (cons 'Cc mct) follow-to)))
- (let (ccalist)
- (save-excursion
- (message-set-work-buffer)
- (unless never-mct
- (insert (or reply-to from "")))
- (insert (if to (concat (if (bolp) "" ", ") to "") ""))
- (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
- (insert (if cc (concat (if (bolp) "" ", ") cc) ""))
- (goto-char (point-min))
- (while (re-search-forward "[ \t]+" nil t)
- (replace-match " " t t))
- ;; Remove addresses that match `rmail-dont-reply-to-names'.
- (let ((rmail-dont-reply-to-names message-dont-reply-to-names))
- (insert (prog1 (rmail-dont-reply-to (buffer-string))
- (erase-buffer))))
- (goto-char (point-min))
- ;; Perhaps Mail-Copies-To: never removed the only address?
- (when (eobp)
- (insert (or reply-to from "")))
- (setq ccalist
- (mapcar
- (lambda (addr)
- (cons (mail-strip-quoted-names addr) addr))
- (message-tokenize-header (buffer-string))))
- (let ((s ccalist))
- (while s
- (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
- (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
- (when ccalist
- (let ((ccs (cons 'Cc (mapconcat
- (lambda (addr) (cdr addr)) ccalist ", "))))
- (when (string-match "^ +" (cdr ccs))
- (setcdr ccs (substring (cdr ccs) (match-end 0))))
- (push ccs follow-to))))))
- (widen))
-
- (message-pop-to-buffer (message-buffer-name
- (if wide "wide reply" "reply") from
- (if wide to-address nil)))
+ date (message-fetch-field "date")
+ from (message-fetch-field "from")
+ subject (or (message-fetch-field "subject") "none"))
+ ;; Remove any (buggy) Re:'s that are present and make a
+ ;; proper one.
+ (when (string-match message-subject-re-regexp subject)
+ (setq subject (substring subject (match-end 0))))
+ (setq subject (concat "Re: " subject))
+
+ (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
+ (string-match "<[^>]+>" gnus-warning))
+ (setq message-id (match-string 0 gnus-warning)))
+
+ (unless follow-to
+ (setq follow-to (message-get-reply-headers wide to-address))))
+
+ (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 ""))
;;;###autoload
-(defun message-cancel-news ()
- "Cancel an article you posted."
- (interactive)
+(defun message-cancel-news (&optional arg)
+ "Cancel an article you posted.
+If ARG, allow editing of the cancellation message."
+ (interactive "P")
(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 sender)
(save-excursion
- ;; Get header info. from original article.
+ ;; Get header info from original article.
(save-restriction
(message-narrow-to-head)
(setq from (message-fetch-field "from")
(message-make-from))))))
(error "This article is not yours"))
;; Make control message.
- (setq buf (set-buffer (get-buffer-create " *message cancel*")))
+ (if arg
+ (message-news)
+ (setq buf (set-buffer (get-buffer-create " *message cancel*"))))
(erase-buffer)
(insert "Newsgroups: " newsgroups "\n"
"From: " (message-make-from) "\n"
mail-header-separator "\n"
message-cancel-message)
(run-hooks 'message-cancel-hook)
- (message "Canceling your article...")
- (if (let ((message-syntax-checks
- 'dont-check-for-anything-just-trust-me))
- (funcall message-send-news-function))
- (message "Canceling your article...done"))
- (kill-buffer buf)))))
+ (unless arg
+ (message "Canceling your article...")
+ (if (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 ()
(cond ((save-window-excursion
(if (not (eq system-type 'vax-vms))
(with-output-to-temp-buffer "*Directory*"
+ (with-current-buffer standard-output
+ (fundamental-mode)) ; for Emacs 20.4+
(buffer-disable-undo standard-output)
(let ((default-directory "/"))
(call-process
(message-mail nil subject))
;; Put point where we want it before inserting the forwarded
;; message.
- (message-goto-body)
+ (if message-forward-before-signature
+ (message-goto-body)
+ (goto-char (point-max)))
(if message-forward-as-mime
- (insert "\n\n<#part type=message/rfc822 disposition=inline>\n")
- (insert "\n\n"))
+ (insert "\n\n<#part type=message/rfc822 disposition=inline>\n")
+ (insert "\n-------------------- Start of forwarded message --------------------\n"))
(let ((b (point))
e)
(mml-insert-buffer cur)
(setq e (point))
- (and message-forward-as-mime
- (insert "<#/part>\n"))
+ (if message-forward-as-mime
+ (insert "<#/part>\n")
+ (insert "\n-------------------- End of forwarded message --------------------\n"))
(when (and (not current-prefix-arg)
message-forward-ignored-headers)
(save-restriction
(save-excursion
(with-output-to-temp-buffer " *MESSAGE information message*"
(set-buffer " *MESSAGE information message*")
+ (fundamental-mode) ; for Emacs 20.4+
(mapcar 'princ text)
(goto-char (point-min))))
(funcall ask question))
(defun message-encode-message-body ()
(unless message-inhibit-body-encoding
(let ((mail-parse-charset (or mail-parse-charset
- message-default-charset
- message-posting-charset))
+ message-default-charset))
(case-fold-search t)
lines content-type-p)
(message-goto-body)
(run-hooks 'message-load-hook)
+;; Local Variables:
+;; coding: iso-8859-1
+;; End:
+
;;; message.el ends here
projects / gnus / blobdiff