(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)
+(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-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-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...")
(autoload 'gnus-alive-p "gnus-util")
(autoload 'gnus-server-string "gnus")
(autoload 'gnus-group-name-charset "gnus-group")
+ (autoload 'gnus-group-name-decode "gnus-group")
+ (autoload 'gnus-groups-from-server "gnus")
(autoload 'rmail-output "rmailout"))
\f
(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-b" 'message-goto-body)
(define-key message-mode-map "\C-c\C-t" 'message-insert-to)
(define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups)
+ (define-key message-mode-map "\C-c\C-p" 'message-insert-or-toggle-importance)
(define-key message-mode-map "\C-c\C-y" 'message-yank-original)
(define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer)
(define-key message-mode-map "\C-c\C-s" 'message-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 "\C-c\n" 'gnus-delay-article)
(define-key message-mode-map "\C-c\C-e" 'message-elide-region)
(define-key message-mode-map "\C-c\C-v" 'message-delete-not-region)
;;(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"))]
["Postpone Message" message-dont-send
,@(if (featurep 'xemacs) '(t)
'(:help "File this draft message and exit"))]
+ ["Send at Specific Time" gnus-delay-article
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Ask, then arrange to send message at that time"))]
["Kill Message" message-kill-buffer
,@(if (featurep 'xemacs) '(t)
'(:help "Delete this message without sending"))]))
["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.
+
+(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-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'."
+ (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-p `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)
+ ;; Mmmm... Forbidden properties...
+ (add-hook 'after-change-functions 'message-strip-forbidden-properties nil t)
;; Allow mail alias things.
(when (eq message-mail-alias-type 'abbrev)
(if (fboundp 'mail-abbrevs-setup)
(unless (boundp 'adaptive-fill-first-line-regexp)
(setq adaptive-fill-first-line-regexp nil))
(make-local-variable 'adaptive-fill-first-line-regexp)
- (make-local-variable 'auto-fill-inhibit-regexp)
(let ((quote-prefix-regexp
;; User should change message-cite-prefix-regexp if
;; message-yank-prefix is set to an abnormal value.
(concat quote-prefix-regexp "\\|" adaptive-fill-regexp))
(setq adaptive-fill-first-line-regexp
(concat quote-prefix-regexp "\\|"
- adaptive-fill-first-line-regexp))
- (setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:")))
+ adaptive-fill-first-line-regexp)))
+ (make-local-variable 'auto-fill-inhibit-regexp)
+ ;;(setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:")
+ (setq auto-fill-inhibit-regexp nil)
+ (make-local-variable 'normal-auto-fill-function)
+ (setq normal-auto-fill-function 'message-do-auto-fill)
+ ;; KLUDGE: auto fill might already be turned on in `text-mode-hook'.
+ ;; In that case, ensure that it uses the right function. The real
+ ;; solution would be not to use `define-derived-mode', and run
+ ;; `text-mode-hook' ourself at the end of the mode.
+ ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-19.
+ (when auto-fill-function
+ (setq auto-fill-function normal-auto-fill-function)))
\f
(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."
+ (unless (message-point-in-header-p)
+ (do-auto-fill)))
+
(defun message-insert-signature (&optional force)
"Insert a signature. See documentation for variable `message-signature'."
(interactive (list 0))
(goto-char (point-max))
(or (bolp) (insert "\n")))))
+(defun message-insert-importance-high ()
+ "Insert header to mark message as important."
+ (interactive)
+ (message-remove-header "Importance")
+ (message-goto-eoh)
+ (insert "Importance: high\n"))
+
+(defun message-insert-importance-low ()
+ "Insert header to mark message as unimportant."
+ (interactive)
+ (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)
- (let (last-line)
- ;; `last-line' describes the contents of the last line
- ;; encountered in the loop below. nil means "empty line",
- ;; spaces "line consisting entirely of whitespace",
- ;; right-angle "line starts with >", quoted "quote character
- ;; at the beginning of the line", text "the remaining cases".
- (while (< (point) (mark t))
- (cond
- ((eolp)
+ (while (< (point) (mark t))
+ (if (or (looking-at ">") (looking-at "^$"))
(insert message-yank-cited-prefix)
- (setq last-line nil))
- ((looking-at ">")
- (if (memq last-line '(nil spaces right-angle quoted))
- (progn
- (insert message-yank-cited-prefix)
- (setq last-line 'quoted))
- (insert message-yank-prefix)
- (setq last-line 'right-angle)))
- ((looking-at "\\s-+$")
- (insert message-yank-prefix)
- (setq last-line 'spaces))
- (t
- (insert message-yank-prefix)
- (setq last-line 'text)))
- (forward-line 1)))))
+ (insert message-yank-prefix))
+ (forward-line 1))))
(goto-char start)))
(defun message-yank-original (&optional arg)
(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)
(insert "Mime-Version: 1.0\n")
(setq header (buffer-substring (point-min) (point-max))))
(goto-char (point-max))
- (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n"
+ (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n\n"
id n total))
+ (forward-char -1)
(let ((mail-header-separator ""))
(when (memq 'Message-ID message-required-mail-headers)
(insert "Message-ID: " (message-make-message-id) "\n"))
(when (memq 'Lines message-required-mail-headers)
- (let ((mail-header-separator ""))
- (insert "Lines: " (message-make-lines) "\n")))
+ (insert "Lines: " (message-make-lines) "\n"))
(message-goto-subject)
(end-of-line)
(insert (format " (%d/%d)" n total))
- (goto-char (point-max))
- (insert "\n")
(widen)
(mm-with-unibyte-current-buffer
(funcall (or message-send-mail-real-function
(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-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)
(method (if (message-functionp message-post-method)
(funcall message-post-method arg)
message-post-method))
- (group-name-charset (gnus-group-name-charset method ""))
+ (newsgroups-field (save-restriction
+ (message-narrow-to-headers-or-head)
+ (message-fetch-field "Newsgroups")))
+ (followup-field (save-restriction
+ (message-narrow-to-headers-or-head)
+ (message-fetch-field "Followup-To")))
+ ;; BUG: We really need to get the charset for each name in the
+ ;; Newsgroups and Followup-To lines to allow crossposting
+ ;; between group namess with incompatible character sets.
+ ;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2001-10-08.
+ (group-field-charset
+ (gnus-group-name-charset method newsgroups-field))
+ (followup-field-charset
+ (gnus-group-name-charset method (or followup-field "")))
(rfc2047-header-encoding-alist
- (if group-name-charset
- (cons (cons "Newsgroups" group-name-charset)
- rfc2047-header-encoding-alist)
- rfc2047-header-encoding-alist))
+ (append (when group-field-charset
+ (list (cons "Newsgroups" group-field-charset)))
+ (when followup-field-charset
+ (list (cons "Followup-To" followup-field-charset)))
+ rfc2047-header-encoding-alist))
(messbuf (current-buffer))
(message-syntax-checks
- (if arg
+ (if (and arg
+ (listp message-syntax-checks))
(cons '(existing-newsgroups . disabled)
message-syntax-checks)
message-syntax-checks))
(message-this-is-news t)
- (message-posting-charset (gnus-setup-posting-charset
- (save-restriction
- (message-narrow-to-headers-or-head)
- (message-fetch-field "Newsgroups"))))
+ (message-posting-charset
+ (gnus-setup-posting-charset newsgroups-field))
result)
(if (not (message-check-news-body-syntax))
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))
- (when group-name-charset
+ ;; Note: This check will be disabled by the ".*" default value for
+ ;; gnus-group-name-charset-group-alist. -- Pa 2001-10-07.
+ (when (and group-field-charset
+ (listp message-syntax-checks))
(setq message-syntax-checks
(cons '(valid-newsgroups . disabled)
message-syntax-checks)))
(if followup-to
(concat newsgroups "," followup-to)
newsgroups)))
+ (post-method (if (message-functionp message-post-method)
+ (funcall message-post-method)
+ message-post-method))
+ ;; KLUDGE to handle nnvirtual groups. Doing this right
+ ;; would probably involve a new nnoo function.
+ ;; -- Per Abrahamsen <abraham@dina.kvl.dk>, 2001-10-17.
+ (method (if (and (consp post-method)
+ (eq (car post-method) 'nnvirtual)
+ gnus-message-group-art)
+ (let ((group (car (nnvirtual-find-group-art
+ (car gnus-message-group-art)
+ (cdr gnus-message-group-art)))))
+ (gnus-find-method-for-group group))
+ post-method))
(known-groups
- (mapcar (lambda (n) (gnus-group-real-name n))
- (gnus-groups-from-server
- (if (message-functionp message-post-method)
- (funcall message-post-method)
- message-post-method))))
+ (mapcar (lambda (n)
+ (gnus-group-name-decode
+ (gnus-group-real-name n)
+ (gnus-group-name-charset method n)))
+ (gnus-groups-from-server method)))
errors)
(while groups
(unless (or (equal (car groups) "poster")
(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)))
+ (mft-regexps (apply 'append message-subscribed-regexps
+ (mapcar 'regexp-quote
+ message-subscribed-addresses)
+ (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
;;; (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.
(Subject . ,(or subject ""))))))
(defun message-get-reply-headers (wide &optional to-address)
- (let (follow-to mct never-mct from to cc reply-to mrt mft ccalist)
+ (let (follow-to mct never-mct to cc author mft recipients)
;; Find all relevant headers we need.
- (setq from (message-fetch-field "from")
- to (message-fetch-field "to")
+ (setq to (message-fetch-field "to")
cc (message-fetch-field "cc")
mct (message-fetch-field "mail-copies-to")
- reply-to (message-fetch-field "reply-to")
- mrt (message-fetch-field "mail-reply-to")
+ author (or (message-fetch-field "mail-reply-to")
+ (message-fetch-field "reply-to")
+ (message-fetch-field "from")
+ "")
mft (and message-use-mail-followup-to
(message-fetch-field "mail-followup-to")))
(setq mct nil))
((or (equal (downcase mct) "always")
(equal (downcase mct) "poster"))
- (setq mct (or mrt reply-to from)))))
+ (setq mct author))))
- (if (and (not mft)
- (or (not wide)
- to-address))
- (progn
- (setq follow-to (list (cons 'To (or to-address mrt reply-to from))))
- (when (and (and wide mct)
- (not (member (cons 'To mct) follow-to)))
- (push (cons 'Cc mct) follow-to)))
- (let (ccalist)
- (save-excursion
- (message-set-work-buffer)
- (if (and mft
- wide
- (or (not (eq message-use-mail-followup-to 'ask))
- (message-y-or-n-p
- (concat "Obey Mail-Followup-To? ") t "\
+ (save-match-data
+ ;; Build (textual) list of new recipient addresses.
+ (cond
+ ((not wide)
+ (setq recipients (concat ", " author)))
+ ((and mft
+ (string-match "[^ \t,]" mft)
+ (or (not (eq message-use-mail-followup-to 'ask))
+ (message-y-or-n-p "Obey Mail-Followup-To? " t "\
You should normally obey the Mail-Followup-To: header. In this
article, it has the value of
Also, some source/announcement lists are not intended for discussion;
responses here are directed to other addresses.")))
- (insert mft)
- (unless never-mct
- (insert (or mrt 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 mrt 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)))
- ;; Allow the user to be asked whether or not to reply to all
- ;; recipients in a wide reply.
- (if (and ccalist wide message-wide-reply-confirm-recipients
- (not (y-or-n-p "Reply to all recipients? ")))
- (setq follow-to (delq (assoc 'Cc follow-to) follow-to)))))
+ (setq recipients (concat ", " mft)))
+ (to-address
+ (setq recipients (concat ", " to-address))
+ ;; If the author explicitly asked for a copy, we don't deny it to them.
+ (if mct (setq recipients (concat recipients ", " mct))))
+ (t
+ (setq recipients (if never-mct "" (concat ", " author)))
+ (if to (setq recipients (concat recipients ", " to)))
+ (if cc (setq recipients (concat recipients ", " cc)))
+ (if mct (setq recipients (concat recipients ", " mct)))))
+ (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)))
+ ;; Remove addresses that match `rmail-dont-reply-to-names'.
+ (let ((rmail-dont-reply-to-names message-dont-reply-to-names))
+ (setq recipients (rmail-dont-reply-to recipients)))
+ ;; Perhaps "Mail-Copies-To: never" removed the only address?
+ (if (string-equal recipients "")
+ (setq recipients author))
+ ;; Convert string to a list of (("foo@bar" . "Name <foo@bar>") ...).
+ (setq recipients
+ (mapcar
+ (lambda (addr)
+ (cons (mail-strip-quoted-names addr) addr))
+ (message-tokenize-header recipients)))
+ ;; Remove first duplicates. (Why not all duplicates? Is this a bug?)
+ (let ((s recipients))
+ (while s
+ (setq recipients (delq (assoc (car (pop s)) s) recipients))))
+ ;; Build the header alist. Allow the user to be asked whether
+ ;; or not to reply to all recipients in a wide reply.
+ (setq follow-to (list (cons 'To (cdr (pop recipients)))))
+ (when (and recipients
+ (or (not message-wide-reply-confirm-recipients)
+ (y-or-n-p "Reply to all recipients? ")))
+ (setq recipients (mapconcat
+ (lambda (addr) (cdr addr)) recipients ", "))
+ (if (string-match "^ +" recipients)
+ (setq recipients (substring recipients (match-end 0))))
+ (push (cons 'Cc recipients) follow-to)))
follow-to))
-
;;;###autoload
(defun message-reply (&optional to-address wide)
"Start editing a reply to the article in the current buffer."
message-id (message-fetch-field "message-id" t)
distribution (message-fetch-field "distribution")))
;; Make sure that this article was written by the user.
- (unless (or (message-gnksa-enable-p 'cancel-messages)
- (and sender
- (string-equal
- (downcase sender)
- (downcase (message-make-sender))))
- (string-equal
- (downcase (cadr (mail-extract-address-components from)))
- (downcase (cadr (mail-extract-address-components
- (message-make-from))))))
+ (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)
+ (downcase (message-make-sender))))
+ (string-equal
+ (downcase (cadr (mail-extract-address-components from)))
+ (downcase (cadr (mail-extract-address-components
+ (message-make-from))))))
(error "This article is not yours"))
(when (yes-or-no-p "Do you really want to cancel this article? ")
;; Make control message.
(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)
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.
'("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name))
"Alist of (RE . FUN). Use FUN for completion on header lines matching RE.")
+(defvar message-tab-body-function 'indent-relative
+ "*Function to execute when `message-tab' (TAB) is executed in the body.")
+
(defun message-tab ()
"Complete names according to `message-completion-alist'.
Do an `indent-relative' if not in those headers."
(let ((mail-abbrev-mode-regexp (caar alist)))
(not (mail-abbrev-in-expansion-header-p))))
(setq alist (cdr alist)))
- (funcall (or (cdar alist) 'indent-relative))))
+ (funcall (or (cdar alist) message-tab-body-function))))
(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