-;;; message.el --- composing mail and news messages -*- coding: iso-latin-1 -*-
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001
+;;; message.el --- composing mail and news messages
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
(eval-when-compile
(require 'cl)
(defvar gnus-list-identifiers)) ; gnus-sum is required where necessary
+(require 'canlock)
(require 'mailheader)
(require 'nnheader)
;; This is apparently necessary even though things are autoloaded:
(require 'mail-parse)
(require 'mml)
(require 'rfc822)
+(eval-and-compile
+ (autoload 'sha1 "sha1-el"))
(defgroup message '((user-mail-address custom-variable)
(user-full-name custom-variable))
:group 'message-headers
:type 'regexp)
-(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:"
+(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:"
"*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."
(const use)
(const ask)))
+(defcustom message-subscribed-address-functions nil
+ "*Specifies functions for determining list subscription.
+If nil, do not attempt to determine list subscribtion with functions.
+If non-nil, this variable contains a list of functions which return
+regular expressions to match lists. These functions can be used in
+conjunction with `message-subscribed-regexps' and
+`message-subscribed-addresses'."
+ :group 'message-interface
+ :type '(repeat sexp))
+
+(defcustom message-subscribed-address-file nil
+ "*A file containing addresses the user is subscribed to.
+If nil, do not look at any files to determine list subscriptions. If
+non-nil, each line of this file should be a mailing list address."
+ :group 'message-interface
+ :type 'string)
+
+(defcustom message-subscribed-addresses nil
+ "*Specifies a list of addresses the user is subscribed to.
+If nil, do not use any predefined list subscriptions. This list of
+addresses can be used in conjuction with
+`message-subscribed-address-functions' and `message-subscribed-regexps'."
+ :group 'message-interface
+ :type '(repeat string))
+
+(defcustom message-subscribed-regexps nil
+ "*Specifies a list of addresses the user is subscribed to.
+If nil, do not use any predefined list subscriptions. This list of
+regular expressions can be used in conjuction with
+`message-subscribed-address-functions' and `message-subscribed-addresses'."
+ :group 'message-interface
+ :type '(repeat regexp))
+
+(defcustom message-allow-no-recipients 'ask
+ "Specifies what to do when there are no recipients other than Gcc/Fcc.
+If it is the symbol `always', the posting is allowed. If it is the
+symbol `never', the posting is not allowed. If it is the symbol
+`ask', you are prompted."
+ :group 'message-interface
+ :type '(choice (const always)
+ (const never)
+ (const ask)))
+
(defcustom message-sendmail-f-is-evil nil
"*Non-nil means don't add \"-f username\" to the sendmail command line.
Doing so would be even more evil than leaving it out."
:group 'message-headers
:type 'boolean)
+(defcustom message-insert-canlock t
+ "Whether to insert a Cancel-Lock header in news postings."
+ :group 'message-headers
+ :type 'boolean)
+
;;; Internal variables.
(defvar message-sending-message "Sending...")
(define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups)
(define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution)
(define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to)
+ (define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to)
(define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords)
(define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary)
+ (define-key message-mode-map "\C-c\C-f\C-i" 'message-insert-or-toggle-importance)
(define-key message-mode-map "\C-c\C-b" 'message-goto-body)
(define-key message-mode-map "\C-c\C-i" 'message-goto-signature)
;;(define-key message-mode-map "\M-q" 'message-fill-paragraph)
(define-key message-mode-map "\C-c\C-a" 'mml-attach-file)
-
+
+ (define-key message-mode-map "\C-a" 'message-beginning-of-line)
(define-key message-mode-map "\t" 'message-tab)
(define-key message-mode-map "\M-;" 'comment-region))
["Kill To Signature" message-kill-to-signature t]
["Newline and Reformat" message-newline-and-reformat t]
["Rename buffer" message-rename-buffer t]
+ ["Flag as important" message-insert-importance-high
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Mark this message as important"))]
+ ["Flag as unimportant" message-insert-importance-low
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Mark this message as unimportant"))]
["Spellcheck" ispell-message
,@(if (featurep 'xemacs) '(t)
'(:help "Spellcheck this message"))]
["Keywords" message-goto-keywords t]
["Newsgroups" message-goto-newsgroups t]
["Followup-To" message-goto-followup-to t]
+ ["Mail-Followup-To" message-goto-mail-followup-to t]
["Distribution" message-goto-distribution t]
["Body" message-goto-body t]
["Signature" message-goto-signature t]))
(defvar facemenu-add-face-function)
(defvar facemenu-remove-face-function))
+;;; Forbidden properties
+;;
+;; We use `after-change-functions' to keep special text properties
+;; that interfer with the normal function of message mode out of the
+;; buffer.
+
+(defcustom message-strip-special-text-properties t
+ "Strip special properties from the message buffer.
+
+Emacs has a number of special text properties which can break message
+composing in various ways. If this option is set, message will strip
+these properties from the message composition buffer. However, some
+packages requires these properties to be present in order to work.
+If you use one of these packages, turn this option off, and hope the
+message composition doesn't break too bad."
+ :group 'message-various
+ :type 'boolean)
+
+(defconst message-forbidden-properties
+ ;; No reason this should be clutter up customize. We make it a
+ ;; property list (rather than a list of property symbols), to be
+ ;; directly useful for `remove-text-properties'.
+ '(field nil read-only nil intangible nil invisible nil
+ mouse-face nil modification-hooks nil insert-in-front-hooks nil
+ insert-behind-hooks nil point-entered nil point-left nil)
+ ;; Other special properties:
+ ;; category, face, display: probably doesn't do any harm.
+ ;; fontified: is used by font-lock.
+ ;; syntax-table, local-map: I dunno.
+ ;; We need to add XEmacs names to the list.
+ "Property list of with properties.forbidden in message buffers.
+The values of the properties are ignored, only the property names are used.")
+
+(defun message-tamago-not-in-use-p (pos)
+ "Return t when tamago version 4 is not in use at the cursor position.
+Tamago version 4 is a popular input method for writing Japanese text.
+It uses the properties `intangible', `invisible', `modification-hooks'
+and `read-only' when translating ascii or kana text to kanji text.
+These properties are essential to work, so we should never strip them."
+ (not (and (boundp 'egg-modefull-mode)
+ (symbol-value 'egg-modefull-mode)
+ (or (memq (get-text-property pos 'intangible)
+ '(its-part-1 its-part-2))
+ (get-text-property pos 'egg-end)
+ (get-text-property pos 'egg-lang)
+ (get-text-property pos 'egg-start)))))
+
+(defun message-strip-forbidden-properties (begin end &optional old-length)
+ "Strip forbidden properties between BEGIN and END, ignoring the third arg.
+This function is intended to be called from `after-change-functions'.
+See also `message-forbidden-properties'."
+ (when (and message-strip-special-text-properties
+ (message-tamago-not-in-use-p begin))
+ (remove-text-properties begin end message-forbidden-properties)))
+
;;;###autoload
(define-derived-mode message-mode text-mode "Message"
"Major mode for editing mail and news to be sent.
C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups
C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution
C-c C-f C-f move to Followup-To
+ C-c C-f C-m move to Mail-Followup-To
C-c C-t `message-insert-to' (add a To header to a news followup)
C-c C-n `message-insert-newsgroups' (add a Newsgroup header to a news reply)
C-c C-b `message-goto-body' (move to beginning of message text).
C-c C-z `message-kill-to-signature' (kill the text up to the signature).
C-c C-r `message-caesar-buffer-body' (rot13 the message body).
C-c C-a `mml-attach-file' (attach a file as MIME).
+C-c C-u `message-insert-or-toggle-importance' (insert or cycle importance)
M-RET `message-newline-and-reformat' (break the line and reformat)."
(set (make-local-variable 'message-reply-buffer) nil)
(make-local-variable 'message-send-actions)
(set (make-local-variable 'tool-bar-map) (message-tool-bar-map))))
(easy-menu-add message-mode-menu message-mode-map)
(easy-menu-add message-mode-field-menu message-mode-map)
+ ;; make-local-hook is harmless though obsolete in Emacs 21.
+ ;; Emacs 20 and XEmacs need make-local-hook.
+ (make-local-hook 'after-change-functions)
+ ;; Mmmm... Forbidden properties...
+ (add-hook 'after-change-functions 'message-strip-forbidden-properties
+ nil 'local)
;; Allow mail alias things.
(when (eq message-mail-alias-type 'abbrev)
(if (fboundp 'mail-abbrevs-setup)
(interactive)
(message-position-on-field "Followup-To" "Newsgroups"))
+(defun message-goto-mail-followup-to ()
+ "Move point to the Mail-Followup-To header."
+ (interactive)
+ (message-position-on-field "Mail-Followup-To" "From"))
+
(defun message-goto-keywords ()
"Move point to the Keywords header."
(interactive)
(message-newline-and-reformat arg t)
t))
+;; Is it better to use `mail-header-end'?
+(defun message-point-in-header-p ()
+ "Return t if point is in the header."
+ (save-excursion
+ (let ((p (point)))
+ (goto-char (point-min))
+ (not (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n")
+ p t)))))
+
(defun message-do-auto-fill ()
"Like `do-auto-fill', but don't fill in message header."
- (when (> (point) (save-excursion (rfc822-goto-eoh)))
+ (unless (message-point-in-header-p)
(do-auto-fill)))
(defun message-insert-signature (&optional force)
(goto-char (point-max))
(or (bolp) (insert "\n")))))
+(defun message-insert-importance-high ()
+ "Insert header to mark message as important."
+ (interactive)
+ (save-excursion
+ (message-remove-header "Importance")
+ (message-goto-eoh)
+ (insert "Importance: high\n")))
+
+(defun message-insert-importance-low ()
+ "Insert header to mark message as unimportant."
+ (interactive)
+ (save-excursion
+ (message-remove-header "Importance")
+ (message-goto-eoh)
+ (insert "Importance: low\n")))
+
+(defun message-insert-or-toggle-importance ()
+ "Insert a \"Importance: high\" header, or cycle through the header values.
+The three allowed values according to RFC 1327 are `high', `normal'
+and `low'."
+ (interactive)
+ (save-excursion
+ (let ((valid '("high" "normal" "low"))
+ (new "high")
+ cur)
+ (when (setq cur (message-fetch-field "Importance"))
+ (message-remove-header "Importance")
+ (setq new (cond ((string= cur "high")
+ "low")
+ ((string= cur "low")
+ "normal")
+ (t
+ "high"))))
+ (message-goto-eoh)
+ (insert (format "Importance: %s\n" new)))))
+
(defun message-elide-region (b e)
"Elide the text in the region.
An ellipsis (from `message-elide-ellipsis') will be inserted where the
(indent-rigidly start (mark t) message-indentation-spaces)
(save-excursion
(goto-char start)
- (while (< (point) (mark t))
- (if (looking-at ">")
+ (while (< (point) (mark t))
+ (if (or (looking-at ">") (looking-at "^$"))
(insert message-yank-cited-prefix)
(insert message-yank-prefix))
(forward-line 1))))
(interactive)
(when (or (not (buffer-modified-p))
(yes-or-no-p "Message modified; kill anyway? "))
- (let ((actions message-kill-actions))
+ (let ((actions message-kill-actions)
+ (draft-article message-draft-article)
+ (auto-save-file-name buffer-auto-save-file-name)
+ (file-name buffer-file-name)
+ (modified (buffer-modified-p)))
(setq buffer-file-name nil)
(kill-buffer (current-buffer))
+ (when (and (or (and auto-save-file-name
+ (file-exists-p auto-save-file-name))
+ (and file-name
+ (file-exists-p file-name)))
+ (yes-or-no-p (format "Remove the backup file%s? "
+ (if modified " too" ""))))
+ (ignore-errors
+ (delete-file auto-save-file-name))
+ (let ((message-draft-article draft-article))
+ (message-disassociate-draft)))
(message-do-actions actions))))
(defun message-bury (buffer)
(message message-sending-message)
(let ((alist message-send-method-alist)
(success t)
- elem sent
+ elem sent dont-barf-on-no-method
(message-options message-options))
(message-options-set-recipient)
(while (and success
(error "Denied posting -- multiple copies")))
(setq success (funcall (caddr elem) arg)))
(setq sent t))))
- (unless (or sent (not success))
+ (unless (or sent
+ (not success)
+ (let ((fcc (message-fetch-field "Fcc"))
+ (gcc (message-fetch-field "Gcc")))
+ (when (or fcc gcc)
+ (or (eq message-allow-no-recipients 'always)
+ (and (not (eq message-allow-no-recipients 'never))
+ (setq dont-barf-on-no-method
+ (gnus-y-or-n-p
+ (format "No receiver, perform %s anyway? "
+ (cond ((and fcc gcc) "Fcc and Gcc")
+ (fcc "Fcc")
+ (t "Gcc"))))))))))
(error "No methods specified to send by"))
- (when (and success sent)
+ (when (or dont-barf-on-no-method
+ (and success sent))
(message-do-fcc)
(save-excursion
(run-hooks 'message-sent-hook))
(put 'message-check 'lisp-indent-function 1)
(put 'message-check 'edebug-form-spec '(form body))
+(defun message-text-with-property (prop)
+ "Return a list of all points where the text has PROP."
+ (let ((points nil)
+ (point (point-min)))
+ (save-excursion
+ (while (< point (point-max))
+ (when (get-text-property point prop)
+ (push point points))
+ (incf point)))
+ (nreverse points)))
+
(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.
(insert "\n"))
;; Delete all invisible text.
(message-check 'invisible-text
- (when (text-property-any (point-min) (point-max) 'invisible t)
- (put-text-property (point-min) (point-max) 'invisible nil)
- (unless (yes-or-no-p
- "Invisible text found and made visible; continue posting? ")
- (error "Invisible text found and made visible")))))
+ (let ((points (message-text-with-property 'invisible)))
+ (when points
+ (goto-char (car points))
+ (dolist (point points)
+ (add-text-properties point (1+ point)
+ '(invisible nil highlight t)))
+ (unless (yes-or-no-p
+ "Invisible text found and made visible; continue posting? ")
+ (error "Invisible text found and made visible"))))))
(defun message-add-action (action &rest types)
"Add ACTION to be performed when doing an exit of type TYPES."
(message-posting-charset
(if (fboundp 'gnus-setup-posting-charset)
(gnus-setup-posting-charset nil)
- message-posting-charset)))
+ message-posting-charset))
+ (headers message-required-mail-headers))
(save-restriction
(message-narrow-to-headers)
+ ;; Generate the Mail-Followup-To header if the header is not there...
+ (if (and (or message-subscribed-regexps
+ message-subscribed-addresses
+ message-subscribed-address-file
+ message-subscribed-address-functions)
+ (not (mail-fetch-field "mail-followup-to")))
+ (setq headers
+ (cons
+ (cons "Mail-Followup-To" (message-make-mft))
+ message-required-mail-headers))
+ ;; otherwise, delete the MFT header if the field is empty
+ (when (equal "" (mail-fetch-field "mail-followup-to"))
+ (message-remove-header "^Mail-Followup-To:")))
;; Insert some headers.
(let ((message-deletable-headers
(if news nil message-deletable-headers)))
- (message-generate-headers message-required-mail-headers))
+ (message-generate-headers headers))
;; Let the user do all of the above.
(run-hooks 'message-header-hook))
(unwind-protect
;; Pass it on to mh.
(mh-send-letter)))
+(defun message-canlock-generate ()
+ "Return a string that is non-trival to guess.
+Do not use this for anything important, it is cryptographically weak."
+ (sha1 (concat (message-unique-id)
+ (format "%x%x%x" (random) (random t) (random))
+ (prin1-to-string (recent-keys))
+ (prin1-to-string (garbage-collect)))))
+
+(defun message-canlock-password ()
+ "The password used by message for cancel locks.
+This is the value of `canlock-password', if that option is non-nil.
+Otherwise, generate and save a value for `canlock-password' first."
+ (unless canlock-password
+ (customize-save-variable 'canlock-password (message-canlock-generate)))
+ canlock-password)
+
+(defun message-insert-canlock ()
+ (when message-insert-canlock
+ (message-canlock-password)
+ (canlock-insert-header)))
+
(defun message-send-news (&optional arg)
(let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
(case-fold-search nil)
(message-narrow-to-headers)
;; Insert some headers.
(message-generate-headers message-required-news-headers)
+ (message-insert-canlock)
;; Let the user do all of the above.
(run-hooks 'message-header-hook))
;; Note: This check will be disabled by the ".*" default value for
(or mail-host-address
(message-make-fqdn)))
+(defun message-make-mft ()
+ "Return the Mail-Followup-To header."
+ (let* ((msg-recipients (message-options-get 'message-recipients))
+ (recipients
+ (mapcar 'mail-strip-quoted-names
+ (message-tokenize-header msg-recipients)))
+ (file-regexps
+ (if message-subscribed-address-file
+ (let (begin end item re)
+ (save-excursion
+ (with-temp-buffer
+ (insert-file-contents message-subscribed-address-file)
+ (while (not (eobp))
+ (setq begin (point))
+ (forward-line 1)
+ (setq end (point))
+ (if (bolp) (setq end (1- end)))
+ (setq item (regexp-quote (buffer-substring begin end)))
+ (if re (setq re (concat re "\\|" item))
+ (setq re (concat "\\`\\(" item))))
+ (and re (list (concat re "\\)\\'"))))))))
+ (mft-regexps (apply 'append message-subscribed-regexps
+ (mapcar 'regexp-quote
+ message-subscribed-addresses)
+ file-regexps
+ (mapcar 'funcall
+ message-subscribed-address-functions))))
+ (save-match-data
+ (when (eval (apply 'append '(or)
+ (mapcar
+ (function (lambda (regexp)
+ (mapcar
+ (function (lambda (recipient)
+ `(string-match ,regexp
+ ,recipient)))
+ recipients)))
+ mft-regexps)))
+ msg-recipients))))
+
(defun message-generate-headers (headers)
"Prepare article HEADERS.
Headers already prepared in the buffer are not modified."
(forward-line 2)))
(sit-for 0)))
+(defun message-beginning-of-line (&optional n)
+ "Move point to beginning of header value or to beginning of line."
+ (interactive "p")
+ (if (message-point-in-header-p)
+ (let* ((here (point))
+ (bol (progn (beginning-of-line n) (point)))
+ (eol (gnus-point-at-eol))
+ (eoh (re-search-forward ": *" eol t)))
+ (if (or (not eoh) (equal here eoh))
+ (goto-char bol)
+ (goto-char eoh)))
+ (beginning-of-line n)))
+
(defun message-buffer-name (type &optional to group)
"Return a new (unique) buffer name based on TYPE and TO."
(cond
headers)
nil switch-function yank-action actions)))))
-;;;(defvar mc-modes-alist)
(defun message-setup-1 (headers &optional replybuffer actions)
-;;; (when (and (boundp 'mc-modes-alist)
-;;; (not (assq 'message-mode mc-modes-alist)))
-;;; (push '(message-mode (encrypt . mc-encrypt-message)
-;;; (sign . mc-sign-message))
-;;; mc-modes-alist))
- (when actions
- (setq message-send-actions actions))
+ (dolist (action actions)
+ (condition-case nil
+ (add-to-list 'message-send-actions
+ `(apply ',(car action) ',(cdr action)))))
(setq message-reply-buffer replybuffer)
(goto-char (point-min))
;; Insert all the headers.
(if to (setq recipients (concat recipients ", " to)))
(if cc (setq recipients (concat recipients ", " cc)))
(if mct (setq recipients (concat recipients ", " mct)))))
- ;; Strip the leading ", ".
- (setq recipients (substring recipients 2))
+ (if (>= (length recipients) 2)
+ ;; Strip the leading ", ".
+ (setq recipients (substring recipients 2)))
;; Squeeze whitespace.
(while (string-match "[ \t][ \t]+" recipients)
(setq recipients (replace-match " " t t recipients)))
;; <abraham@dina.kvl.dk>
;;
;; IF article has cancel-lock THEN
- ;; IF we can load canlock THEN
- ;; IF we can verify it THEN
- ;; issue cancel
- ;; ELSE
- ;; error: cancellock: article is not yours
+ ;; IF we can verify it THEN
+ ;; issue cancel
;; ELSE
- ;; error: message is cancel locked
+ ;; error: cancellock: article is not yours
;; ELSE
;; Use old rules, comparing sender...
(if (message-fetch-field "Cancel-Lock")
- (if (ignore-errors (require 'canlock))
- (if (null (canlock-verify))
- t
- (error "Failed to verify Cancel-lock: This article is not yours"))
- (error "This article is cancel locked, the `canlock.el' library is required."))
+ (if (null (canlock-verify))
+ t
+ (error "Failed to verify Cancel-lock: This article is not yours"))
nil)
(message-gnksa-enable-p 'cancel-messages)
(and sender
(sender (message-fetch-field "sender"))
(from (message-fetch-field "from")))
;; Check whether the user owns the article that is to be superseded.
- (unless (or (message-gnksa-enable-p 'cancel-messages)
+ (unless (or
+ ;; Canlock-logic as suggested by Per Abrahamsen
+ ;; <abraham@dina.kvl.dk>
+ ;;
+ ;; IF article has cancel-lock THEN
+ ;; IF we can verify it THEN
+ ;; issue cancel
+ ;; ELSE
+ ;; error: cancellock: article is not yours
+ ;; ELSE
+ ;; Use old rules, comparing sender...
+ (if (message-fetch-field "Cancel-Lock")
+ (if (null (canlock-verify))
+ t
+ (error "Failed to verify Cancel-lock: This article is not yours"))
+ nil)
+ (message-gnksa-enable-p 'cancel-messages)
(and sender
(string-equal
(downcase sender)
"Remove junk like \"Re:\", \"(fwd)\", etc. added to subject string SUBJECT.
Previous forwarders, replyers, etc. may add it."
(with-temp-buffer
- (insert-string subject)
+ (insert subject)
(goto-char (point-min))
;; strip Re/Fwd stuff off the beginning
(while (re-search-forward
the list of newsgroups is was posted to."
(concat "["
(let ((prefix
- (or (message-fetch-field
- (if (message-news-p) "newsgroups" "from"))
+ (or (message-fetch-field "newsgroups")
+ (message-fetch-field "from")
"(nowhere)")))
(if message-forward-decoded-p
prefix
(eval-when-compile
(defvar gnus-article-decoded-p))
+
;;;###autoload
(defun message-forward (&optional news digest)
"Forward the current message via mail.
(if (local-variable-p 'gnus-article-decoded-p (current-buffer))
gnus-article-decoded-p ;; In an article buffer.
message-forward-decoded-p))
- (subject (message-make-forward-subject))
- art-beg)
+ (subject (message-make-forward-subject)))
(if news
(message-news nil subject)
(message-mail nil subject))
- ;; Put point where we want it before inserting the forwarded
- ;; message.
- (if message-forward-before-signature
- (message-goto-body)
- (goto-char (point-max)))
- (if message-forward-as-mime
- (if digest
- (insert "\n<#multipart type=digest>\n")
- (if message-forward-show-mml
- (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")
- (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")))
- (insert "\n-------------------- Start of forwarded message --------------------\n"))
- (let ((b (point)) e)
+ (message-forward-make-body cur digest)))
+
+;;;###autoload
+(defun message-forward-make-body (forward-buffer &optional digest)
+ ;; Put point where we want it before inserting the forwarded
+ ;; message.
+ (if message-forward-before-signature
+ (message-goto-body)
+ (goto-char (point-max)))
+ (if message-forward-as-mime
(if digest
- (if message-forward-as-mime
- (insert-buffer-substring cur)
- (mml-insert-buffer cur))
- (if (and message-forward-show-mml
- (not message-forward-decoded-p))
- (insert
- (with-temp-buffer
- (mm-disable-multibyte-mule4) ;; Must copy buffer in unibyte mode
+ (insert "\n<#multipart type=digest>\n")
+ (if message-forward-show-mml
+ (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")
+ (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")))
+ (insert "\n-------------------- Start of forwarded message --------------------\n"))
+ (let ((b (point)) e)
+ (if digest
+ (if message-forward-as-mime
+ (insert-buffer-substring forward-buffer)
+ (mml-insert-buffer forward-buffer))
+ (if (and message-forward-show-mml
+ (not message-forward-decoded-p))
+ (insert
+ (with-temp-buffer
+ (mm-disable-multibyte-mule4) ;; Must copy buffer in unibyte mode
(insert
- (with-current-buffer cur
+ (with-current-buffer forward-buffer
(mm-string-as-unibyte (buffer-string))))
(mm-enable-multibyte-mule4)
(mime-to-mml)
(when (looking-at "From ")
(replace-match "X-From-Line: "))
(buffer-string)))
- (save-restriction
- (narrow-to-region (point) (point))
- (mml-insert-buffer cur)
- (goto-char (point-min))
- (when (looking-at "From ")
- (replace-match "X-From-Line: "))
- (goto-char (point-max)))))
- (setq e (point))
- (if message-forward-as-mime
- (if digest
- (insert "<#/multipart>\n")
- (if message-forward-show-mml
- (insert "<#/mml>\n")
- (insert "<#/part>\n")))
- (insert "\n-------------------- End of forwarded message --------------------\n"))
- (if (and digest message-forward-as-mime)
- (save-restriction
- (narrow-to-region b e)
- (goto-char b)
- (narrow-to-region (point)
- (or (search-forward "\n\n" nil t) (point)))
- (delete-region (point-min) (point-max)))
- (when (and (not current-prefix-arg)
- message-forward-ignored-headers)
- (save-restriction
- (narrow-to-region b e)
- (goto-char b)
- (narrow-to-region (point)
- (or (search-forward "\n\n" nil t) (point)))
- (message-remove-header message-forward-ignored-headers t)))))
- (message-position-point)))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (mml-insert-buffer forward-buffer)
+ (goto-char (point-min))
+ (when (looking-at "From ")
+ (replace-match "X-From-Line: "))
+ (goto-char (point-max)))))
+ (setq e (point))
+ (if message-forward-as-mime
+ (if digest
+ (insert "<#/multipart>\n")
+ (if message-forward-show-mml
+ (insert "<#/mml>\n")
+ (insert "<#/part>\n")))
+ (insert "\n-------------------- End of forwarded message --------------------\n"))
+ (if (and digest message-forward-as-mime)
+ (save-restriction
+ (narrow-to-region b e)
+ (goto-char b)
+ (narrow-to-region (point)
+ (or (search-forward "\n\n" nil t) (point)))
+ (delete-region (point-min) (point-max)))
+ (when (and (not current-prefix-arg)
+ message-forward-ignored-headers)
+ (save-restriction
+ (narrow-to-region b e)
+ (goto-char b)
+ (narrow-to-region (point)
+ (or (search-forward "\n\n" nil t) (point)))
+ (message-remove-header message-forward-ignored-headers t)))))
+ (message-position-point))
+
+;;;###autoload
+(defun message-forward-rmail-make-body (forward-buffer)
+ (save-window-excursion
+ (set-buffer forward-buffer)
+ (let (rmail-enable-mime)
+ (rmail-toggle-header 0)))
+ (message-forward-make-body forward-buffer))
+
+;;;###autoload
+(defun message-insinuate-rmail ()
+ "Let RMAIL uses message to forward."
+ (interactive)
+ (setq rmail-enable-mime-composing t)
+ (setq rmail-insert-mime-forwarded-message-function
+ 'message-forward-rmail-make-body))
;;;###autoload
(defun message-resend (address)
(tool-bar-add-item-from-menu
'message-dont-send "cancel" message-mode-map)
(tool-bar-add-item-from-menu
- 'mml-attach-file "attach" message-mode-map)
+ 'mml-attach-file "attach" mml-mode-map)
(tool-bar-add-item-from-menu
'ispell-message "spell" message-mode-map)
+ (tool-bar-add-item-from-menu
+ 'message-insert-importance-high "important"
+ message-mode-map)
+ (tool-bar-add-item-from-menu
+ 'message-insert-importance-low "unimportant"
+ message-mode-map)
tool-bar-map)))))
;;; Group name completion.
-(defvar message-newgroups-header-regexp
+(defcustom message-newgroups-header-regexp
"^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):"
- "Regexp that match headers that lists groups.")
+ "Regexp that match headers that lists groups."
+ :group 'message
+ :type 'regexp)
-(defvar message-completion-alist
+(defcustom message-completion-alist
(list (cons message-newgroups-header-regexp 'message-expand-group)
'("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name))
- "Alist of (RE . FUN). Use FUN for completion on header lines matching RE.")
+ "Alist of (RE . FUN). Use FUN for completion on header lines matching RE."
+ :group 'message
+ :type '(alist :key-type regexp :value-type function))
-(defvar message-tab-body-function 'indent-relative
- "*Function to execute when `message-tab' (TAB) is executed in the body.")
+(defcustom message-tab-body-function nil
+ "*Function to execute when `message-tab' (TAB) is executed in the body.
+If nil, the function bound in `text-mode-map' or `global-map' is executed."
+ :group 'message
+ :type 'function)
(defun message-tab ()
"Complete names according to `message-completion-alist'.
-Do an `indent-relative' if not in those headers."
+Execute function specified by `message-tab-body-function' when not in
+those headers."
(interactive)
(let ((alist message-completion-alist))
(while (and alist
(let ((mail-abbrev-mode-regexp (caar alist)))
(not (mail-abbrev-in-expansion-header-p))))
(setq alist (cdr alist)))
- (funcall (or (cdar alist) message-tab-body-function))))
+ (funcall (or (cdar alist) message-tab-body-function
+ (lookup-key text-mode-map "\t")
+ (lookup-key global-map "\t")
+ 'indent-relative))))
(defun message-expand-group ()
"Expand the group name under point."
;; /usr/bin/mail.
(unless content-type-p
(goto-char (point-min))
- (re-search-forward "^MIME-Version:")
- (forward-line 1)
- (insert "Content-Type: text/plain; charset=us-ascii\n")))))
+ ;; For unknown reason, MIME-Version doesn't exist.
+ (when (re-search-forward "^MIME-Version:" nil t)
+ (forward-line 1)
+ (insert "Content-Type: text/plain; charset=us-ascii\n"))))))
(defun message-read-from-minibuffer (prompt)
"Read from the minibuffer while providing abbrev expansion."
projects / gnus / blobdiff