;;; message.el --- composing mail and news messages
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
(defvar gnus-list-identifiers)) ; gnus-sum is required where necessary
(eval-and-compile
(if (boundp 'MULE)
- (require 'canlock-om)
+ (progn
+ (require 'base64)
+ (require 'canlock-om))
(require 'canlock)))
(require 'mailheader)
(require 'nnheader)
-;; This is apparently necessary even though things are autoloaded:
+;; This is apparently necessary even though things are autoloaded.
+;; Because we dynamically bind mail-abbrev-mode-regexp, we'd better
+;; require mailabbrev here.
(if (featurep 'xemacs)
- (require 'mail-abbrevs))
+ (require 'mail-abbrevs)
+ (require 'mailabbrev))
(require 'mime-edit)
(eval-when-compile (require 'static))
:group 'message-sending
:type '(repeat (symbol :tag "Type")))
+(defcustom message-fcc-externalize-attachments nil
+ "If non-nil, attachments are included as external parts in Fcc copies."
+ :type 'boolean
+ :group 'message-sending)
+
(defcustom message-courtesy-message
"The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n"
"*This is inserted at the start of a mailed copy of a posted message.
:group 'message-sending
:type 'function)
+;;; Start of variables adopted from `message-utils.el'.
+
+(defcustom message-subject-trailing-was-query 'ask
+ ;; should it default to nil or ask?
+ "*What to do with trailing \"(was: <old subject>)\" in subject lines.
+If nil, leave the subject unchanged. If it is the symbol `ask', query
+the user what do do. In this case, the subject is matched against
+`message-subject-trailing-was-ask-regexp'. If
+`message-subject-trailing-was-query' is t, always strip the trailing
+old subject. In this case, `message-subject-trailing-was-regexp' is
+used."
+ :type '(choice (const :tag "never" nil)
+ (const :tag "always strip" t)
+ (const ask))
+ :group 'message-various)
+
+(defcustom message-subject-trailing-was-ask-regexp
+ "[ \t]*\\([[(]+[Ww][Aa][Ss][ \t]*.*[\])]+\\)"
+ "*Regexp matching \"(was: <old subject>)\" in the subject line.
+
+The function `message-strip-subject-trailing-was' uses this regexp if
+`message-subject-trailing-was-query' is set to the symbol `ask'. If
+the variable is t instead of `ask', use
+`message-subject-trailing-was-regexp' instead.
+
+It is okay to create some false positives here, as the user is asked."
+ :group 'message-various
+ :type 'regexp)
+
+(defcustom message-subject-trailing-was-regexp
+ "[ \t]*\\((*[Ww][Aa][Ss]:[ \t]*.*)\\)"
+ "*Regexp matching \"(was: <old subject>)\" in the subject line.
+
+If `message-subject-trailing-was-query' is set to t, the subject is
+matched against `message-subject-trailing-was-regexp' in
+`message-strip-subject-trailing-was'. You should use a regexp creating very
+few false positives here."
+ :group 'message-various
+ :type 'regexp)
+
+;;; marking inserted text
+
+;;;###autoload
+(defcustom message-mark-insert-begin
+ "--8<---------------cut here---------------start------------->8---\n"
+ "How to mark the beginning of some inserted text."
+ :type 'string
+ :group 'message-various)
+
+;;;###autoload
+(defcustom message-mark-insert-end
+ "--8<---------------cut here---------------end--------------->8---\n"
+ "How to mark the end of some inserted text."
+ :type 'string
+ :group 'message-various)
+
+;;;###autoload
+(defcustom message-archive-header
+ "X-No-Archive: Yes\n"
+ "Header to insert when you don't want your article to be archived.
+Archives \(such as groups.googgle.com\) respect this header."
+ :type 'string
+ :group 'message-various)
+
+;;;###autoload
+(defcustom message-archive-note
+ "X-No-Archive: Yes - save http://groups.google.com/"
+ "Note to insert why you wouldn't want this posting archived.
+If nil, don't insert any text in the body."
+ :type 'string
+ :group 'message-various)
+
+;;; Crossposts and Followups
+;; inspired by JoH-followup-to by Jochem Huhman <joh at gmx.de>
+;; new suggestions by R. Weikusat <rw at another.de>
+
+(defvar message-xpost-old-target nil
+ "Old target for cross-posts or follow-ups.")
+(make-variable-buffer-local 'message-xpost-old-target)
+
+;;;###autoload
+(defcustom message-xpost-default t
+ "When non-nil `message-xpost-fup2' will normally perform a crosspost.
+If nil, `message-xpost-fup2' will only do a followup. Note that you
+can explicitly override this setting by calling `message-xpost-fup2'
+with a prefix."
+ :type 'boolean
+ :group 'message-various)
+
+;;;###autoload
+(defcustom message-xpost-note
+ "Crosspost & Followup-To: "
+ "Note to insert before signature to notify of xpost and follow-up."
+ :type 'string
+ :group 'message-various)
+
+;;;###autoload
+(defcustom message-fup2-note
+ "Followup-To: "
+ "Note to insert before signature to notify of follow-up only."
+ :type 'string
+ :group 'message-various)
+
+;;;###autoload
+(defcustom message-xpost-note-function
+ 'message-xpost-insert-note
+ "Function to use to insert note about Crosspost or Followup-To.
+The function will be called with four arguments. The function should not only
+insert a note, but also ensure old notes are deleted. See the documentation
+for `message-xpost-insert-note'. "
+ :type 'function
+ :group 'message-various)
+
+;;; End of variables adopted from `message-utils.el'.
+
;;;###autoload
(defcustom message-from-style 'default
"*Specifies how \"From\" headers look.
(const default))
:group 'message-headers)
-(defcustom message-syntax-checks nil
+(defcustom message-insert-canlock t
+ "Whether to insert a Cancel-Lock header in news postings."
+ :version "21.3"
+ :group 'message-headers
+ :type 'boolean)
+
+(defcustom message-syntax-checks
+ (if message-insert-canlock '((sender . disabled)) nil)
;; 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
:type 'sexp)
(defcustom message-ignored-news-headers
- "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:\\|^X-Draft-From:"
+ "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:"
"*Regexp of headers to be removed unconditionally before posting."
:group 'message-news
:group 'message-headers
:type 'regexp)
(defcustom message-ignored-mail-headers
- "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:\\|^X-Draft-From:"
+ "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:"
"*Regexp of headers to be removed unconditionally before mailing."
:group 'message-mail
: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:\\|^Cancel-Lock:\\|^Cancel-Key:"
+(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:\\|^X-Hashcash:"
"*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."
:group 'message-sending
:type 'function)
-(defcustom message-subject-re-regexp "^[ \t]*\\([Rr][Ee]:[ \t]*\\)*[ \t]*"
+(defcustom message-subject-re-regexp
+ "^[ \t]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)*:[ \t]*\\)*[ \t]*"
"*Regexp matching \"Re: \" in the subject line."
:group 'message-various
:type 'regexp)
:type 'string
:group 'message-various)
-(defcustom message-interactive nil
+(defcustom message-interactive t
"Non-nil means when sending a message wait for and display errors.
nil means let mailer mail back a message to report errors."
:group 'message-sending
:group 'message-forwarding
:type 'boolean)
-(defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:"
+(defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:\\|^>?From "
"*All headers that match this regexp will be deleted when resending a message."
:group 'message-interface
:type 'regexp)
(defcustom message-cite-prefix-regexp
(if (string-match "[[:digit:]]" "1") ;; support POSIX?
- "\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>~|:}+]\\)+"
+ "\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>|}+]\\)+"
;; ?-, ?_ or ?. MUST NOT be in syntax entry w.
- "\\([ \t]*\\(\\w\\|[-_.]\\)+>+\\|[ \t]*[]>~|:}+]\\)+")
+ (let ((old-table (syntax-table))
+ non-word-constituents)
+ (set-syntax-table text-mode-syntax-table)
+ (setq non-word-constituents
+ (concat
+ (if (string-match "\\w" "-") "" "-")
+ (if (string-match "\\w" "_") "" "_")
+ (if (string-match "\\w" ".") "" ".")))
+ (set-syntax-table old-table)
+ (if (equal non-word-constituents "")
+ "\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}+]\\)+"
+ (concat "\\([ \t]*\\(\\w\\|["
+ non-word-constituents
+ "]\\)+>+\\|[ \t]*[]>|}+]\\)+"))))
"*Regexp matching the longest possible citation prefix on a line."
:group 'message-insertion
:type 'regexp)
Valid values include `message-send-mail-with-sendmail' (the default),
`message-send-mail-with-mh', `message-send-mail-with-qmail',
-`message-send-mail-with-smtp', `smtpmail-send-it' and `feedmail-send-it'.
+`message-send-mail-with-smtp', `message-smtpmail-send-it',
+`smtpmail-send-it' and `feedmail-send-it'.
See also `send-mail-function'."
:type '(radio (function-item message-send-mail-with-sendmail)
(function-item message-send-mail-with-mh)
(function-item message-send-mail-with-qmail)
(function-item message-send-mail-with-smtp)
+ (function-item message-smtpmail-send-it)
(function-item smtpmail-send-it)
(function-item feedmail-send-it)
(function :tag "Other"))
(defcustom message-qmail-inject-args nil
"Arguments passed to qmail-inject programs.
-This should be a list of strings, one string for each argument.
+This should be a list of strings, one string for each argument. It
+may also be a function.
For e.g., if you wish to set the envelope sender address so that bounces
go to the right place or to deal with listserv's usage of that address, you
might set this variable to '(\"-f\" \"you@some.where\")."
:group 'message-sending
- :type '(repeat string))
+ :type '(choice (function)
+ (repeat string)))
(defvar message-cater-to-broken-inn t
"Non-nil means Gnus should not fold the `References' header.
:type 'function
:group 'message-insertion)
-(defvar message-abbrevs-loaded nil)
-
;;;###autoload
(defcustom message-signature t
"*String to be inserted at the end of the message buffer.
(sexp :tag "none" :format "%t" t)))
(defvar message-reply-buffer nil)
-(defvar message-reply-headers nil)
+(defvar message-reply-headers nil
+ "The headers of the current replied article.
+It is a vector of the following headers:
+\[number subject from date id references chars lines xref extra].")
(defvar message-sent-message-via nil)
(defvar message-checksum nil)
(defvar message-send-actions nil
:group 'message-buffers
:type '(choice directory (const :tag "Don't auto-save" nil)))
-(defcustom message-buffer-naming-style 'unique
- "*The way new message buffers are named.
-Valid valued are `unique' and `unsent'."
- :version "21.1"
- :group 'message-buffers
- :type '(choice (const :tag "unique" unique)
- (const :tag "unsent" unsent)))
-
(defcustom message-default-charset
(and (featurep 'xemacs) (not (featurep 'mule)) 'iso-8859-1)
"Default charset used in non-MULE XEmacsen."
candidates:
`empty-article' Allow you to post an empty article;
`quoted-text-only' Allow you to post quoted text only;
-`multiple-copies' Allow you to post multiple copies.")
-;; `cancel-messages' Allow you to cancel or supersede others' messages.
+`multiple-copies' Allow you to post multiple copies;
+`cancel-messages' Allow you to cancel or supersede messages from
+ your other email addresses.")
(defsubst message-gnksa-enable-p (feature)
(or (not (listp message-shoot-gnksa-feet))
"Face used for displaying MML."
:group 'message-faces)
+(defun message-font-lock-make-header-matcher (regexp)
+ (let ((form
+ `(lambda (limit)
+ (let ((start (point)))
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (if (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$")
+ nil t)
+ (setq limit (min limit (match-beginning 0))))
+ (goto-char start))
+ (and (< start limit)
+ (re-search-forward ,regexp limit t))))))
+ (if (featurep 'bytecomp)
+ (byte-compile form)
+ form)))
+
(defvar message-font-lock-keywords
(let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?"))
- `((,(concat "^\\([Tt]o:\\)" content)
+ `((,(message-font-lock-make-header-matcher
+ (concat "^\\([Tt]o:\\)" content))
(1 'message-header-name-face)
(2 'message-header-to-face nil t))
- (,(concat "^\\([GBF]?[Cc][Cc]:\\|[Rr]eply-[Tt]o:\\|"
- "[Mm]ail-[Cc]opies-[Tt]o:\\|"
- "[Mm]ail-[Rr]eply-[Tt]o:\\|"
- "[Mm]ail-[Ff]ollowup-[Tt]o:\\)" content)
+ (,(message-font-lock-make-header-matcher
+ (concat "^\\([GBF]?[Cc][Cc]:\\|[Rr]eply-[Tt]o:\\|"
+ "[Mm]ail-[Cc]opies-[Tt]o:\\|"
+ "[Mm]ail-[Rr]eply-[Tt]o:\\|"
+ "[Mm]ail-[Ff]ollowup-[Tt]o:\\)" content))
(1 'message-header-name-face)
(2 'message-header-cc-face nil t))
- (,(concat "^\\([Ss]ubject:\\)" content)
+ (,(message-font-lock-make-header-matcher
+ (concat "^\\([Ss]ubject:\\)" content))
(1 'message-header-name-face)
(2 'message-header-subject-face nil t))
- (,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)
+ (,(message-font-lock-make-header-matcher
+ (concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content))
(1 'message-header-name-face)
(2 'message-header-newsgroups-face nil t))
- (,(concat "^\\([A-Z][^: \n\t]+:\\)" content)
+ (,(message-font-lock-make-header-matcher
+ (concat "^\\([A-Z][^: \n\t]+:\\)" content))
(1 'message-header-name-face)
(2 'message-header-other-face nil t))
- (,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content)
+ (,(message-font-lock-make-header-matcher
+ (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content))
(1 'message-header-name-face)
(2 'message-header-name-face))
,@(if (and mail-header-separator
`((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
1 'message-separator-face))
nil)
- (,(concat "^\\(" message-cite-prefix-regexp "\\).*")
+ ((lambda (limit)
+ (re-search-forward (concat "^\\("
+ message-cite-prefix-regexp
+ "\\).*")
+ limit t))
(0 'message-cited-text-face))
(,mime-edit-tag-regexp
(0 'message-mml-face))))
(const :tag "ask" ask)))
(defvar message-draft-coding-system
- (cond
- ((boundp 'MULE) '*junet*)
- ((not (fboundp 'find-coding-system)) nil)
- ((find-coding-system 'emacs-mule)
- (if (memq system-type '(windows-nt ms-dos ms-windows))
- 'emacs-mule-dos 'emacs-mule))
- ((find-coding-system 'escape-quoted) 'escape-quoted)
- ((find-coding-system 'no-conversion) 'no-conversion)
- (t nil))
+ nnheader-auto-save-coding-system
"Coding system to compose mail.")
(defcustom message-send-mail-partially-limit 1000000
:type '(choice (const :tag "Always use primary" nil)
regexp))
+(defcustom message-hierarchical-addresses nil
+ "A list of hierarchical mail address definitions.
+
+Inside each entry, the first address is the \"top\" address, and
+subsequent addresses are subaddresses; this is used to indicate that
+mail sent to the first address will automatically be delivered to the
+subaddresses. So if the first address appears in the recipient list
+for a message, the subaddresses will be removed (if present) before
+the mail is sent. All addresses in this structure should be
+downcased."
+ :group 'message-headers
+ :type '(repeat (repeat string)))
+
(defcustom message-mail-user-agent nil
"Like `mail-user-agent'.
Except if it is nil, use Gnus native MUA; if it is t, use
recipients?\" before a wide reply to multiple recipients. If the user
answers yes, reply to all recipients as usual. If the user answers
no, only reply back to the author."
- :group 'message-headers
- :type 'boolean)
-
-(defcustom message-insert-canlock t
- "Whether to insert a Cancel-Lock header in news postings."
+ :version "21.3"
:group 'message-headers
:type 'boolean)
(autoload 'gnus-point-at-bol "gnus-util")
(autoload 'gnus-output-to-rmail "gnus-util")
(autoload 'gnus-output-to-mail "gnus-util")
- (autoload 'mail-abbrev-in-expansion-header-p "mailabbrev")
(autoload 'nndraft-request-associate-buffer "nndraft")
(autoload 'nndraft-request-expire-articles "nndraft")
(autoload 'gnus-open-server "gnus-int")
(substring subject (match-end 0))
subject))
+;;; Start of functions adopted from `message-utils.el'.
+
+(defun message-strip-subject-trailing-was (subject)
+ "Remove trailing \"(Was: <old subject>)\" from subject lines.
+Leading \"Re: \" is not stripped by this function. Use the function
+`message-strip-subject-re' for this."
+ (let* ((query message-subject-trailing-was-query)
+ (new) (found))
+ (setq found
+ (string-match
+ (if (eq query 'ask)
+ message-subject-trailing-was-ask-regexp
+ message-subject-trailing-was-regexp)
+ subject))
+ (if found
+ (setq new (substring subject 0 (match-beginning 0))))
+ (if (or (not found) (eq query nil))
+ subject
+ (if (eq query 'ask)
+ (if (message-y-or-n-p
+ "Strip `(was: <old subject>)' in subject? " t
+ (concat
+ "Strip `(was: <old subject>)' in subject "
+ "and use the new one instead?\n\n"
+ "Current subject is: \""
+ subject "\"\n\n"
+ "New subject would be: \""
+ new "\"\n\n"
+ "See the variable `message-subject-trailing-was-query' "
+ "to get rid of this query."
+ ))
+ new subject)
+ new))))
+
+;;; Suggested by Jonas Steverud @ www.dtek.chalmers.se/~d4jonas/
+
+;;;###autoload
+(defun message-change-subject (new-subject)
+ "Ask for new Subject: header, append (was: <Old Subject>)."
+ (interactive
+ (list
+ (read-from-minibuffer "New subject: ")))
+ (cond ((and (not (or (null new-subject) ; new subject not empty
+ (zerop (string-width new-subject))
+ (string-match "^[ \t]*$" new-subject))))
+ (save-excursion
+ (let ((old-subject (message-fetch-field "Subject")))
+ (cond ((not old-subject)
+ (error "No current subject."))
+ ((not (string-match
+ (concat "^[ \t]*"
+ (regexp-quote new-subject)
+ " \t]*$")
+ old-subject)) ; yes, it really is a new subject
+ ;; delete eventual Re: prefix
+ (setq old-subject
+ (message-strip-subject-re old-subject))
+ (message-goto-subject)
+ (message-delete-line)
+ (insert (concat "Subject: "
+ new-subject
+ " (was: "
+ old-subject ")\n")))))))))
+
+;;;###autoload
+(defun message-mark-inserted-region (beg end)
+ "Mark some region in the current article with enclosing tags.
+See `message-mark-insert-begin' and `message-mark-insert-end'."
+ (interactive "r")
+ (save-excursion
+ ; add to the end of the region first, otherwise end would be invalid
+ (goto-char end)
+ (insert message-mark-insert-end)
+ (goto-char beg)
+ (insert message-mark-insert-begin)))
+
+;;;###autoload
+(defun message-mark-insert-file (file)
+ "Inserts FILE at point, marking it with enclosing tags.
+See `message-mark-insert-begin' and `message-mark-insert-end'."
+ (interactive "fFile to insert: ")
+ ;; reverse insertion to get correct result.
+ (let ((p (point)))
+ (insert message-mark-insert-end)
+ (goto-char p)
+ (insert-file-contents file)
+ (goto-char p)
+ (insert message-mark-insert-begin)))
+
+;;;###autoload
+(defun message-add-archive-header ()
+ "Insert \"X-No-Archive: Yes\" in the header and a note in the body.
+The note can be customized using `message-archive-note'. When called with a
+prefix argument, ask for a text to insert. If you don't want the note in the
+body, set `message-archive-note' to nil."
+ (interactive)
+ (if current-prefix-arg
+ (setq message-archive-note
+ (read-from-minibuffer "Reason for No-Archive: "
+ (cons message-archive-note 0))))
+ (save-excursion
+ (if (message-goto-signature)
+ (re-search-backward message-signature-separator))
+ (when message-archive-note
+ (insert message-archive-note)
+ (newline))
+ (message-add-header message-archive-header)
+ (message-sort-headers)))
+
+;;;###autoload
+(defun message-xpost-fup2-header (target-group)
+ "Mangles FollowUp-To and Newsgroups header to point to TARGET-GROUP.
+With prefix-argument just set Follow-Up, don't cross-post."
+ (interactive
+ (list ; Completion based on Gnus
+ (completing-read "Followup To: "
+ (if (boundp 'gnus-newsrc-alist)
+ gnus-newsrc-alist)
+ nil nil '("poster" . 0)
+ (if (boundp 'gnus-group-history)
+ 'gnus-group-history))))
+ (message-remove-header "Follow[Uu]p-[Tt]o" t)
+ (message-goto-newsgroups)
+ (beginning-of-line)
+ ;; if we already did a crosspost before, kill old target
+ (if (and message-xpost-old-target
+ (re-search-forward
+ (regexp-quote (concat "," message-xpost-old-target))
+ nil t))
+ (replace-match ""))
+ ;; unless (followup is to poster or user explicitly asked not
+ ;; to cross-post, or target-group is already in Newsgroups)
+ ;; add target-group to Newsgroups line.
+ (cond ((and (or
+ ;; def: xpost, req:no
+ (and message-xpost-default (not current-prefix-arg))
+ ;; def: no-xpost, req:yes
+ (and (not message-xpost-default) current-prefix-arg))
+ (not (string-match "poster" target-group))
+ (not (string-match (regexp-quote target-group)
+ (message-fetch-field "Newsgroups"))))
+ (end-of-line)
+ (insert-string (concat "," target-group))))
+ (end-of-line) ; ensure Followup: comes after Newsgroups:
+ ;; unless new followup would be identical to Newsgroups line
+ ;; make a new Followup-To line
+ (if (not (string-match (concat "^[ \t]*"
+ target-group
+ "[ \t]*$")
+ (message-fetch-field "Newsgroups")))
+ (insert (concat "\nFollowup-To: " target-group)))
+ (setq message-xpost-old-target target-group))
+
+;;;###autoload
+(defun message-xpost-insert-note (target-group xpost in-old old-groups)
+ "Insert a in message body note about a set Followup or Crosspost.
+If there have been previous notes, delete them. TARGET-GROUP specifies the
+group to Followup-To. When XPOST is t, insert note about
+crossposting. IN-OLD specifies whether TARGET-GROUP is a member of
+OLD-GROUPS. OLD-GROUPS lists the old-groups the posting would have
+been made to before the user asked for a Crosspost."
+ ;; start scanning body for previous uses
+ (message-goto-signature)
+ (let ((head (re-search-backward
+ (concat "^" mail-header-separator)
+ nil t))) ; just search in body
+ (message-goto-signature)
+ (while (re-search-backward
+ (concat "^" (regexp-quote message-xpost-note) ".*")
+ head t)
+ (message-delete-line))
+ (message-goto-signature)
+ (while (re-search-backward
+ (concat "^" (regexp-quote message-fup2-note) ".*")
+ head t)
+ (message-delete-line))
+ ;; insert new note
+ (if (message-goto-signature)
+ (re-search-backward message-signature-separator))
+ (if (or in-old
+ (not xpost)
+ (string-match "^[ \t]*poster[ \t]*$" target-group))
+ (insert (concat message-fup2-note target-group "\n"))
+ (insert (concat message-xpost-note target-group "\n")))))
+
+;;;###autoload
+(defun message-xpost-fup2 (target-group)
+ "Crossposts message and sets Followup-To to TARGET-GROUP.
+With prefix-argument just set Follow-Up, don't cross-post."
+ (interactive
+ (list ; Completion based on Gnus
+ (completing-read "Followup To: "
+ (if (boundp 'gnus-newsrc-alist)
+ gnus-newsrc-alist)
+ nil nil '("poster" . 0)
+ (if (boundp 'gnus-group-history)
+ 'gnus-group-history))))
+ (cond ((not (or (null target-group) ; new subject not empty
+ (zerop (string-width target-group))
+ (string-match "^[ \t]*$" target-group)))
+ (save-excursion
+ (let* ((old-groups (message-fetch-field "Newsgroups"))
+ (in-old (string-match
+ (regexp-quote target-group)
+ (or old-groups ""))))
+ ;; check whether target exactly matches old Newsgroups
+ (cond ((not old-groups)
+ (error "No current newsgroup."))
+ ((or (not in-old)
+ (not (string-match
+ (concat "^[ \t]*"
+ (regexp-quote target-group)
+ "[ \t]*$")
+ old-groups)))
+ ;; yes, Newsgroups line must change
+ (message-xpost-fup2-header target-group)
+ ;; insert note whether we do xpost or fup2
+ (funcall message-xpost-note-function
+ target-group
+ (if (or (and message-xpost-default
+ (not current-prefix-arg))
+ (and (not message-xpost-default)
+ current-prefix-arg)) t)
+ in-old old-groups))))))))
+
+;;; Reduce To: to Cc: or Bcc: header
+
+;;;###autoload
+(defun message-reduce-to-to-cc ()
+ "Replace contents of To: header with contents of Cc: or Bcc: header."
+ (interactive)
+ (let ((cc-content (message-fetch-field "cc"))
+ (bcc nil))
+ (if (and (not cc-content)
+ (setq cc-content (message-fetch-field "bcc")))
+ (setq bcc t))
+ (cond (cc-content
+ (save-excursion
+ (message-goto-to)
+ (message-delete-line)
+ (insert (concat "To: " cc-content "\n"))
+ (message-remove-header (if bcc
+ "bcc"
+ "cc")))))))
+
+;;; End of functions adopted from `message-utils.el'.
+
(defun message-remove-header (header &optional is-regexp first reverse)
"Remove HEADER in the narrowed buffer.
If IS-REGEXP, HEADER is a regular expression.
(define-key message-mode-map "\C-c?" 'describe-mode)
(define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to)
+ (define-key message-mode-map "\C-c\C-f\C-o" 'message-goto-from)
(define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc)
(define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc)
(define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc)
(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-f\C-a" 'message-gen-unsubscribed-mft)
+
+ ;; modify headers (and insert notes in body)
+ (define-key message-mode-map "\C-c\C-fs" 'message-change-subject)
+ ;;
+ (define-key message-mode-map "\C-c\C-fx" 'message-xpost-fup2)
+ ;; prefix+message-xpost-fup2 = same w/o xpost
+ (define-key message-mode-map "\C-c\C-ft" 'message-reduce-to-to-cc)
+ (define-key message-mode-map "\C-c\C-fa" 'message-add-archive-header)
+ ;; mark inserted text
+ (define-key message-mode-map "\C-c\M-m" 'message-mark-inserted-region)
+ (define-key message-mode-map "\C-c\M-f" 'message-mark-insert-file)
+
(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 "\C-c\C-fc" 'message-goto-mail-copies-to)
(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-l" 'message-to-list-only)
+
+ (define-key message-mode-map "\C-c\C-u" 'message-insert-or-toggle-importance)
+ (define-key message-mode-map "\C-c\M-n" 'message-insert-disposition-notification-to)
(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 "\t" 'message-tab)
(define-key message-mode-map "\M-;" 'comment-region)
- (define-key message-mode-map "\C-x\C-s" 'message-save-drafts)
(define-key message-mode-map "\C-xk" 'message-mimic-kill-buffer))
(easy-menu-define
["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
+ ["Flag As Important" message-insert-importance-high
,@(if (featurep 'xemacs) '(t)
'(:help "Mark this message as important"))]
- ["Flag as unimportant" message-insert-importance-low
+ ["Flag As Unimportant" message-insert-importance-low
,@(if (featurep 'xemacs) '(t)
'(:help "Mark this message as unimportant"))]
+ ["Request Receipt"
+ message-insert-disposition-notification-to
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Request a Disposition Notification of this article"))]
["Spellcheck" ispell-message
,@(if (featurep 'xemacs) '(t)
'(:help "Spellcheck this message"))]
,@(if (featurep 'xemacs) '(t)
'(:help "Attach a file at point"))]
"----"
+ ["Insert Region Marked" message-mark-inserted-region
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Mark region with enclosing tags"))]
+ ["Insert File Marked" message-mark-insert-file
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Insert file at point marked with enclosing tags"))]
+ "----"
["Send Message" message-send-and-exit
,@(if (featurep 'xemacs) '(t)
'(:help "Send this message"))]
["Fetch Newsgroups" message-insert-newsgroups t]
"----"
["To" message-goto-to t]
+ ["From" message-goto-from t]
["Subject" message-goto-subject t]
+ ["Change subject" message-change-subject t]
["Cc" message-goto-cc t]
+ ["Bcc" message-goto-bcc t]
+ ["Fcc" message-goto-fcc t]
["Reply-To" message-goto-reply-to t]
- ["Mail-Reply-To" message-goto-mail-reply-to t]
- ["Mail-Followup-To" message-goto-mail-followup-to t]
- ["Mail-Copies-To" message-goto-mail-copies-to t]
+ "----"
+ ;; (typical) news stuff
["Summary" message-goto-summary t]
["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]
+ ;; ["Followup-To (with note in body)" message-xpost-fup2 t]
+ ["Crosspost / Followup-To" message-xpost-fup2 t]
["Distribution" message-goto-distribution t]
+ ["X-No-Archive:" message-add-archive-header t ]
+ "----"
+ ;; (typical) mailing-lists stuff
+ ["Send to list only" message-to-list-only t]
+ ["Mail-Followup-To" message-goto-mail-followup-to t]
+ ["Mail-Reply-To" message-goto-mail-reply-to t]
+ ["Mail-Copies-To" message-goto-mail-copies-to t]
+ ["Reduce To: to Cc:" message-reduce-to-to-cc t]
+ "----"
["Body" message-goto-body t]
["Signature" message-goto-signature t]))
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))
+ (message-tamago-not-in-use-p begin)
+ ;; Check whether the invisible MIME part is not inserted.
+ (not (text-property-any begin end 'mime-edit-invisible t)))
(remove-text-properties begin end message-forbidden-properties)))
;;;###autoload
C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To
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-o move to From (\"Originator\")
C-c C-f C-f move to Followup-To
C-c C-f C-m move to Mail-Followup-To
C-c C-f c move to Mail-Copies-To
+ C-c C-f C-i cycle through Importance values
+ C-c C-f s change subject and append \"(was: <Old Subject>)\"
+ C-c C-f x crossposting with FollowUp-To header and note in body
+ C-c C-f t replace To: header with contents of Cc: or Bcc:
+ C-c C-f a Insert X-No-Archive: header and a note in the body
C-c C-t `message-insert-to' (add a To header to a news followup)
+C-c C-l `message-to-list-only' (removes all but list address in to/cc)
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-i `message-goto-signature' (move to the beginning of the signature).
C-c C-v `message-delete-not-region' (remove the text outside the region).
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-p `message-insert-or-toggle-importance' (insert or cycle importance)
+C-c C-u `message-insert-or-toggle-importance' (insert or cycle importance).
+C-c M-n `message-insert-disposition-notification-to' (request receipt).
+C-c M-m `message-mark-inserted-region' (mark region with enclosing tags).
+C-c M-f `message-mark-insert-file' (insert file marked with enclosing tags).
M-RET `message-newline-and-reformat' (break the line and reformat)."
+ (setq local-abbrev-table text-mode-abbrev-table)
(set (make-local-variable 'message-reply-buffer) nil)
(make-local-variable 'message-send-actions)
(make-local-variable 'message-exit-actions)
(if (fboundp 'mail-abbrevs-setup)
(mail-abbrevs-setup)
(mail-aliases-setup)))
- (message-set-auto-save-file-name)
+ (unless buffer-file-name
+ (message-set-auto-save-file-name))
(set (make-local-variable 'indent-tabs-mode) nil)) ;No tabs for indentation.
(defun message-setup-fill-variables ()
(interactive)
(message-position-on-field "To"))
+(defun message-goto-from ()
+ "Move point to the From header."
+ (interactive)
+ (message-position-on-field "From"))
+
(defun message-goto-subject ()
"Move point to the Subject header."
(interactive)
(goto-char (point-max))
nil))
+(defun message-gen-unsubscribed-mft (&optional include-cc)
+ "Insert a reasonable MFT header in a post to an unsubscribed list.
+When making original posts to a mailing list you are not subscribed to,
+you have to type in a MFT header by hand. The contents, usually, are
+the addresses of the list and your own address. This function inserts
+such a header automatically. It fetches the contents of the To: header
+in the current mail buffer, and appends the current user-mail-address.
+
+If the optional argument `include-cc' is non-nil, the addresses in the
+Cc: header are also put into the MFT."
+
+ (interactive "P")
+ (message-remove-header "Mail-Followup-To")
+ (let* ((cc (and include-cc (message-fetch-field "Cc")))
+ (tos (if cc
+ (concat (message-fetch-field "To") "," cc)
+ (message-fetch-field "To"))))
+ (message-goto-mail-followup-to)
+ (insert (concat tos ", " user-mail-address))))
+
\f
(defun message-insert-to (&optional force)
(if not-break
(setq point nil)
(if bolp
- (insert "\n")
- (insert "\n\n"))
+ (newline)
+ (newline)
+ (newline))
(setq point (point))
- (insert "\n\n")
+ ;; (newline 2) doesn't mark both newline's as hard, so call
+ ;; newline twice. -jas
+ (newline)
+ (newline)
(delete-region (point) (re-search-forward "[ \t]*"))
(when (and quoted (not bolp))
(insert quoted leading-space)))
(message-goto-eoh)
(insert (format "Importance: %s\n" new)))))
+(defun message-insert-disposition-notification-to ()
+ "Request a disposition notification (return receipt) to this message.
+Note that this should not be used in newsgroups."
+ (interactive)
+ (save-excursion
+ (message-remove-header "Disposition-Notification-To")
+ (message-goto-eoh)
+ (insert (format "Disposition-Notification-To: %s\n"
+ (or (message-fetch-field "From") (message-make-from))))))
+
(defun message-elide-region (b e)
"Elide the text in the region.
An ellipsis (from `message-elide-ellipsis') will be inserted where the
t)))
(defun message-dont-send ()
- "Don't send the message you have been editing."
+ "Don't send the message you have been editing.
+Instead, just auto-save the buffer and then bury it."
(interactive)
- (message-save-drafts)
+ (set-buffer-modified-p t)
+ (save-buffer)
(let ((actions message-postpone-actions)
(frame (selected-frame))
(org-frame message-original-frame))
(success t)
elem sent dont-barf-on-no-method
(message-options message-options))
- (message-options-set-recipient)
- (save-excursion
- (set-buffer message-encoding-buffer)
- (erase-buffer)
- ;; ;; Avoid copying text props.
- ;; T-gnus change: copy all text props from the editing buffer
- ;; into the encoding buffer.
- (insert-buffer message-edit-buffer)
- (funcall message-encode-function)
- (while (and success
- (setq elem (pop alist)))
- (when (funcall (cadr elem))
- (when (and (or (not (memq (car elem)
- message-sent-message-via))
- (if (or (message-gnksa-enable-p 'multiple-copies)
- (not (eq (car elem) 'news)))
- (y-or-n-p
- (format
- "Already sent message via %s; resend? "
- (car elem)))
- (error "Denied posting -- multiple copies")))
- (setq success (funcall (caddr elem) arg)))
- (setq sent t)))))
- (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)
+ (unwind-protect
+ (progn
+ (message-options-set-recipient)
+ (save-excursion
+ (set-buffer message-encoding-buffer)
+ (erase-buffer)
+ ;; ;; Avoid copying text props (except hard newlines).
+ ;; T-gnus change: copy all text props from the editing buffer
+ ;; into the encoding buffer.
+ (insert-buffer-substring message-edit-buffer)
+ (funcall message-encode-function)
+ (while (and success
+ (setq elem (pop alist)))
+ (when (funcall (cadr elem))
+ (when (and
+ (or (not (memq (car elem)
+ message-sent-message-via))
+ (if (or (message-gnksa-enable-p 'multiple-copies)
+ (not (eq (car elem) 'news)))
+ (y-or-n-p
+ (format
+ "Already sent message via %s; resend? "
+ (car elem)))
+ (error "Denied posting -- multiple copies")))
+ (setq success (funcall (caddr elem) arg)))
+ (setq sent t)))))
+ (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
(cond ((and fcc gcc) "Fcc and Gcc")
(fcc "Fcc")
(t "Gcc"))))))))))
- (error "No methods specified to send by"))
- (prog1
- (when (or dont-barf-on-no-method
- (and success sent))
- (message-do-fcc)
- (save-excursion
- (run-hooks 'message-sent-hook))
- (message "Sending...done")
- ;; Mark the buffer as unmodified and delete auto-save.
- (set-buffer-modified-p nil)
- (delete-auto-save-file-if-necessary t)
- (message-disassociate-draft)
- ;; Delete other mail buffers and stuff.
- (message-do-send-housekeeping)
- (message-do-actions message-send-actions)
- ;; Return success.
- t)
+ (error "No methods specified to send by"))
+ (when (or dont-barf-on-no-method
+ (and success sent))
+ (message-do-fcc)
+ (save-excursion
+ (run-hooks 'message-sent-hook))
+ (message "Sending...done")
+ ;; Mark the buffer as unmodified and delete auto-save.
+ (set-buffer-modified-p nil)
+ (delete-auto-save-file-if-necessary t)
+ (message-disassociate-draft)
+ ;; Delete other mail buffers and stuff.
+ (message-do-send-housekeeping)
+ (message-do-actions message-send-actions)
+ ;; Return success.
+ t))
(kill-buffer message-encoding-buffer)))))
(defun message-send-via-mail (arg)
'(invisible t mime-edit-invisible t))
(put-text-property start end 'invisible t))))))
+(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.
(set-window-start (selected-window) (gnus-point-at-bol))
(unless (yes-or-no-p
"Invisible text found and made visible; continue posting? ")
- (error "Invisible text found and made visible"))))))
+ (error "Invisible text found and made visible")))))
+ (message-check 'illegible-text
+ (let ((mm-7bit-chars "\x20-\x7f\r\n\t\x7\x8\xb\xc\x1f\x1b")
+ found choice)
+ (message-goto-body)
+ (skip-chars-forward mm-7bit-chars)
+ (while (not (eobp))
+ (when (let ((char (char-after)))
+ (or (< (mm-char-int char) 128)
+ (and (mm-multibyte-p)
+ (memq (char-charset char)
+ '(eight-bit-control eight-bit-graphic
+ control-1)))))
+ (add-text-properties (point) (1+ (point)) '(highlight t))
+ (setq found t))
+ (forward-char)
+ (skip-chars-forward mm-7bit-chars))
+ (when found
+ (setq choice
+ (gnus-multiple-choice
+ "Illegible text found. Continue posting? "
+ '((?d "Remove and continue posting")
+ (?r "Replace with dots and continue posting")
+ (?i "Ignore and continue posting")
+ (?e "Continue editing"))))
+ (if (eq choice ?e)
+ (error "Illegible text found"))
+ (message-goto-body)
+ (skip-chars-forward mm-7bit-chars)
+ (while (not (eobp))
+ (when (let ((char (char-after)))
+ (or (< (mm-char-int char) 128)
+ (and (mm-multibyte-p)
+ (memq (char-charset char)
+ '(eight-bit-control eight-bit-graphic
+ control-1)))))
+ (if (eq choice ?i)
+ (remove-text-properties (point) (1+ (point)) '(highlight t))
+ (delete-char 1)
+ (if (eq choice ?r)
+ (insert "."))))
+ (forward-char)
+ (skip-chars-forward mm-7bit-chars))))))
(defun message-add-action (action &rest types)
"Add ACTION to be performed when doing an exit of type TYPES."
+ (while types
+ (add-to-list (intern (format "message-%s-actions" (pop types)))
+ action)))
+
+(defun message-delete-action (action &rest types)
+ "Delete ACTION from lists of actions 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))))))
+ (delq action (symbol-value var))))))
(defun message-do-actions (actions)
"Perform all actions in ACTIONS."
(save-excursion
(set-buffer tembuf)
(erase-buffer)
- (insert-buffer message-encoding-buffer)
+ ;; ;; Avoid copying text props (except hard newlines).
+ ;; T-gnus change: copy all text props from the editing buffer
+ ;; into the encoding buffer.
+ (insert-buffer-substring message-encoding-buffer)
;; Remove some headers.
(save-restriction
(message-narrow-to-headers)
;; ;; We (re)generate the Lines header.
;; (when (memq 'Lines message-required-mail-headers)
;; (message-generate-headers '(Lines)))
- ;; Remove some headers.
(message-remove-header message-ignored-mail-headers t))
(goto-char (point-max))
;; require one newline at the end.
" 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))
- (run-hooks 'message-send-mail-hook)
- ;; 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 "/"))
- (as-binary-process
- (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.
- ;; But some systems are more broken with -f, so
- ;; we'll let users override this.
- (if (null message-sendmail-f-is-evil)
- (list "-f" (message-make-address)))
- ;; 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)))))
+ (unwind-protect
+ (progn
+ (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))
+ (run-hooks 'message-send-mail-hook)
+ ;; 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 "/")
+ (cpr (as-binary-process
+ (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.
+ ;; But some systems are more broken with -f, so
+ ;; we'll let users override this.
+ (if (null message-sendmail-f-is-evil)
+ (list "-f" (message-make-address)))
+ ;; 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")))))))
+ (unless (or (null cpr) (zerop cpr))
+ (error "Sending...failed with exit value %d" cpr)))
+ (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)))))
;; free for -inject-arguments -- a big win for the user and for us
;; since we don't have to play that double-guessing game and the user
;; gets full control (no gestapo'ish -f's, for instance). --sj
- message-qmail-inject-args))
+ (if (functionp message-qmail-inject-args)
+ (funcall message-qmail-inject-args)
+ message-qmail-inject-args)))
;; qmail-inject doesn't say anything on it's stdout/stderr,
;; we have to look at the retval instead
(0 nil)
nil)
(not (funcall message-send-news-function method)))))
+(defun message-smtpmail-send-it ()
+ "Send the prepared message buffer with `smtpmail-send-it'.
+This only differs from `smtpmail-send-it' that this command evaluates
+`message-send-mail-hook' just before sending a message. It is useful
+if your ISP requires the POP-before-SMTP authentication. See the
+documentation for the function `mail-source-touch-pop'."
+ (run-hooks 'message-send-mail-hook)
+ (smtpmail-send-it))
+
(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)))))
+ (let (sha1-maximum-internal-length)
+ (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)))
+ (customize-save-variable 'canlock-password (message-canlock-generate))
+ (setq canlock-password-for-verify canlock-password))
canlock-password)
(defun message-insert-canlock ()
(set-buffer tembuf)
(buffer-disable-undo)
(erase-buffer)
- (insert-buffer message-encoding-buffer)
+ (insert-buffer-substring message-encoding-buffer)
;; Remove some headers.
(save-restriction
(message-narrow-to-headers)
(backward-char 1)
(run-hooks 'message-send-news-hook)
(gnus-open-server method)
- (message "Sending news with %s..." (gnus-server-string method))
+ (message "Sending news via %s..." (gnus-server-string method))
(gnus-request-post method)
))
(zerop
(length
(setq to (completing-read
- "Followups to: (default all groups) "
+ "Followups to (default: no Followup-To header) "
(mapcar (lambda (g) (list g))
(cons "poster"
(message-tokenize-header
(erase-buffer)
(goto-char (point-min))
(set-buffer-multibyte nil)
- (insert-buffer message-encoding-buffer)
+ (insert-buffer-substring message-encoding-buffer)
(goto-char (point-min))
(if (re-search-forward "[^\x00-\x7f]" nil t)
(y-or-n-p
(let ((case-fold-search t)
(coding-system-for-write 'raw-text)
(output-coding-system 'raw-text)
- list file)
+ list file
+ (mml-externalize-attachments message-fcc-externalize-attachments))
(save-excursion
(save-restriction
(message-narrow-to-headers)
(aset user (match-beginning 0) ?_))
user)
(message-number-base36 (user-uid) -1))
- (message-number-base36 (+ (car tm)
+ (message-number-base36 (+ (car tm)
(lsh (% message-unique-id-char 25) 16)) 4)
(message-number-base36 (+ (nth 1 tm)
(lsh (/ message-unique-id-char 25) 16)) 4)
(aset tmp (1- (match-end 0)) ?-))
(string-match "[\\()]" tmp)))))
(insert fullname)
- (goto-char (point-min))
- ;; Look for a character that cannot appear unquoted
- ;; according to RFC 822.
- (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1)
- ;; Quote fullname, escaping specials.
- (goto-char (point-min))
- (insert "\"")
- (while (re-search-forward "[\"\\]" nil 1)
- (replace-match "\\\\\\&" t))
- (insert "\""))
(insert " <" login ">"))
(t ; 'parens or default
(insert login " (")
(match-string 1 user-mail))
;; Default to this bogus thing.
(t
- (concat system-name ".i-did-not-set--mail-host-address--so-shoot-me")))))
+ (concat system-name ".i-did-not-set--mail-host-address--so-tickle-me")))))
(defun message-make-host-name ()
"Return the name of the host."
(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))
+(defun message-to-list-only ()
+ "Send a message to the list only.
+Remove all addresses but the list address from To and Cc headers."
+ (interactive)
+ (let ((listaddr (message-make-mft t)))
+ (when listaddr
+ (save-excursion
+ (message-remove-header "to")
+ (message-remove-header "cc")
+ (message-position-on-field "To" "X-Draft-From")
+ (insert listaddr)))))
+
+(defun message-make-mft (&optional only-show-subscribed)
+ "Return the Mail-Followup-To header. If passed the optional
+argument `only-show-subscribed' only return the subscribed address (and
+not the additional To and Cc header contents)."
+ (let* ((case-fold-search t)
+ (to (message-fetch-field "To"))
+ (cc (message-fetch-field "cc"))
+ (msg-recipients (concat to (and to cc ", ") cc))
(recipients
(mapcar 'mail-strip-quoted-names
(message-tokenize-header msg-recipients)))
(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))))
+ (let ((subscribed-lists nil)
+ (list
+ (loop for recipient in recipients
+ when (loop for regexp in mft-regexps
+ when (string-match regexp recipient) return t)
+ return recipient)))
+ (when list
+ (if only-show-subscribed
+ list
+ msg-recipients))))))
;; Dummy to avoid byte-compile warning.
(defvar mule-version)
(goto-char (point-min))
(let ((case-fold-search t)
user-agent start p end)
- (if (re-search-forward "^User-Agent:[\t ]*" nil t)
+ (if (re-search-forward
+ (concat "^User-Agent:[\t ]*\\("
+ (regexp-quote gnus-product-name)
+ "/[0-9.]+\\([ \t\r\n]*([^)]+)\\)*\\)?[\t ]*")
+ nil t)
(progn
(setq start (match-beginning 0)
p (match-end 0)
(goto-char (point-max))
(insert (if (stringp header) header (symbol-name header))
": " value)
+ ;; We check whether the value was ended by a
+ ;; newline. If now, we insert one.
(unless (bolp)
(insert "\n"))
(forward-line -1))
(defun message-beginning-of-line (&optional n)
"Move point to beginning of header value or to beginning of line."
(interactive "p")
+ (let ((zrs 'zmacs-region-stays))
+ (when (and (interactive-p) (boundp zrs))
+ (set zrs t)))
(if (message-point-in-header-p)
(let* ((here (point))
(bol (progn (beginning-of-line n) (point)))
to group)
(if (not (or (null name)
(string-equal name "mail")
- (string-equal name "news")))
+ (string-equal name "posting")))
(setq name (concat "*sent " name "*"))
(message-narrow-to-headers)
(setq to (message-fetch-field "to"))
(or (car (mail-extract-address-components to))
to) "*"))
((and group (not (string= group "")))
- (concat "*sent news on " group "*"))
+ (concat "*sent posting on " group "*"))
(t "*sent mail*"))))
(unless (string-equal name (buffer-name))
(rename-buffer name t)))))
(setq buffer-file-name (expand-file-name
(if (memq system-type
'(ms-dos ms-windows windows-nt
- cygwin32 win32 w32
+ cygwin cygwin32 win32 w32
mswindows))
"message"
"*message*")
"Start editing a news article to be sent."
(interactive)
(let ((message-this-is-news t))
- (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))
+ (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups))
(message-setup `((Newsgroups . ,(or newsgroups ""))
(Subject . ,(or subject ""))))))
;; 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>") ...).
+ ;; Convert string to a list of (("foo@bar" . "Name <Foo@BAR>") ...).
(setq recipients
(mapcar
(lambda (addr)
- (cons (mail-strip-quoted-names addr) addr))
+ (cons (downcase (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))))
+
+ ;; Remove hierarchical lists that are contained within each other,
+ ;; if message-hierarchical-addresses is defined.
+ (when message-hierarchical-addresses
+ (let ((plain-addrs (mapcar 'car recipients))
+ subaddrs recip)
+ (while plain-addrs
+ (setq subaddrs (assoc (car plain-addrs)
+ message-hierarchical-addresses)
+ plain-addrs (cdr plain-addrs))
+ (when subaddrs
+ (setq subaddrs (cdr subaddrs))
+ (while subaddrs
+ (setq recip (assoc (car subaddrs) recipients)
+ subaddrs (cdr subaddrs))
+ (if recip
+ (setq recipients (delq recip 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 gnus-list-identifiers
(setq subject (message-strip-list-identifiers subject)))
(setq subject (message-make-followup-subject subject))
+ (when message-subject-trailing-was-query
+ (setq subject (message-strip-subject-trailing-was subject)))
(when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
(string-match "<[^>]+>" gnus-warning))
(if gnus-list-identifiers
(setq subject (message-strip-list-identifiers subject)))
(setq subject (message-make-followup-subject subject))
+ (when message-subject-trailing-was-query
+ (setq subject (message-strip-subject-trailing-was subject)))
(widen))
;; Handle special values of Mail-Copies-To.
(defun message-forward-make-body (forward-buffer)
;; Put point where we want it before inserting the forwarded
;; message.
+ ;; Note that this function definition for T-gnus is totally different
+ ;; from the original Gnus."
(if message-forward-before-signature
(message-goto-body)
(goto-char (point-max)))
(defun message-forward-rmail-make-body (forward-buffer)
(save-window-excursion
(set-buffer forward-buffer)
- (let (rmail-enable-mime)
- (rmail-toggle-header 0)))
+ ;; Rmail doesn't have rmail-msg-restore-non-pruned-header in Emacs
+ ;; 20. FIXIT, or we drop support for rmail in Emacs 20.
+ (if (rmail-msg-is-pruned)
+ (rmail-msg-restore-non-pruned-header)))
(message-forward-make-body forward-buffer))
;;;###autoload
(special-display-regexps nil)
(same-window-buffer-names nil)
(same-window-regexps nil))
- (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
+ (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups)))
(let ((message-this-is-news t))
(message-setup `((Newsgroups . ,(or newsgroups ""))
(Subject . ,(or subject ""))))))
(special-display-regexps nil)
(same-window-buffer-names nil)
(same-window-regexps nil))
- (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
+ (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups)))
(let ((message-this-is-news t))
(message-setup `((Newsgroups . ,(or newsgroups ""))
(Subject . ,(or subject ""))))))
(defun message-tool-bar-map ()
(or message-tool-bar-map
(setq message-tool-bar-map
- (and (fboundp 'tool-bar-add-item-from-menu)
- tool-bar-mode
- (let ((tool-bar-map (copy-keymap tool-bar-map))
- (load-path (mm-image-load-path)))
- ;; Zap some items which aren't so relevant and take
- ;; up space.
- (dolist (key '(print-buffer kill-buffer save-buffer
- write-file dired open-file))
- (define-key tool-bar-map (vector key) nil))
- (tool-bar-add-item-from-menu
- 'message-send-and-exit "mail_send" message-mode-map)
- (tool-bar-add-item-from-menu
- 'message-kill-buffer "close" message-mode-map)
- (tool-bar-add-item-from-menu
- 'message-dont-send "cancel" message-mode-map)
- (tool-bar-add-item-from-menu
- 'mime-edit-insert-file "attach" message-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)))))
+ (and
+ (condition-case nil (require 'tool-bar) (error nil))
+ (fboundp 'tool-bar-add-item-from-menu)
+ tool-bar-mode
+ (let ((tool-bar-map (copy-keymap tool-bar-map))
+ (load-path (mm-image-load-path)))
+ ;; Zap some items which aren't so relevant and take
+ ;; up space.
+ (dolist (key '(print-buffer kill-buffer save-buffer
+ write-file dired open-file))
+ (define-key tool-bar-map (vector key) nil))
+ (tool-bar-add-item-from-menu
+ 'message-send-and-exit "mail_send" message-mode-map)
+ (tool-bar-add-item-from-menu
+ 'message-kill-buffer "close" message-mode-map)
+ (tool-bar-add-item-from-menu
+ 'message-dont-send "cancel" message-mode-map)
+ (tool-bar-add-item-from-menu
+ 'mime-edit-insert-file "attach" message-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-add-item-from-menu
+ 'message-insert-disposition-notification-to "receipt"
+ message-mode-map)
+ tool-bar-map)))))
;;; Group name completion.
(defcustom message-completion-alist
(list (cons message-newgroups-header-regexp 'message-expand-group)
- '("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name))
+ '("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name)
+ '("^\\(Reply-To\\|From\\|Disposition-Notification-To\\|Return-Receipt-To\\):"
+ . message-expand-name))
"Alist of (RE . FUN). Use FUN for completion on header lines matching RE."
:group 'message
:type '(alist :key-type regexp :value-type function))
+(defcustom message-expand-name-function
+ (if (fboundp 'bbdb-complete-name)
+ 'bbdb-complete-name
+ (if (fboundp 'lsdb-complete-name)
+ 'lsdb-complete-name
+ 'expand-abbrev))
+ "*A function called to expand addresses in field body."
+ :group 'message
+ :type 'function)
+
(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."
(delete-region (point) (progn (forward-line 3) (point))))))))))
(defun message-expand-name ()
- (if (fboundp 'bbdb-complete-name)
- (bbdb-complete-name)
- (expand-abbrev)))
+ (funcall message-expand-name-function))
;;; Help stuff.
(message-narrow-to-headers-or-head)
(message-remove-first-header "Content-Type")
(message-remove-first-header "Content-Transfer-Encoding"))
- ;; We always make sure that the message has a Content-Type header.
- ;; This is because some broken MTAs and MUAs get awfully confused
- ;; when confronted with a message with a MIME-Version header and
- ;; without a Content-Type header. For instance, Solaris'
- ;; /usr/bin/mail.
+ ;; We always make sure that the message has a Content-Type
+ ;; header. This is because some broken MTAs and MUAs get
+ ;; awfully confused when confronted with a message with a
+ ;; MIME-Version header and without a Content-Type header. For
+ ;; instance, Solaris' /usr/bin/mail.
(unless content-type-p
(goto-char (point-min))
;; For unknown reason, MIME-Version doesn't exist.
(forward-line 1)
(insert "Content-Type: text/plain; charset=us-ascii\n"))))))
-(defun message-read-from-minibuffer (prompt)
+(defun message-read-from-minibuffer (prompt &optional initial-contents)
"Read from the minibuffer while providing abbrev expansion."
(if (fboundp 'mail-abbrevs-setup)
(let ((mail-abbrev-mode-regexp "")
(minibuffer-setup-hook 'mail-abbrevs-setup)
(minibuffer-local-map message-minibuffer-local-map))
- (read-from-minibuffer prompt))
+ (read-from-minibuffer prompt initial-contents))
(let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)
(minibuffer-local-map message-minibuffer-local-map))
- (read-string prompt))))
+ (read-string prompt initial-contents))))
(defun message-use-alternative-email-as-from ()
(require 'mail-utils)
(require 'messagexmas)
(message-xmas-redefine))
-(defun message-save-drafts ()
- "Postponing the message."
- (interactive)
- (message "Saving %s..." buffer-file-name)
- (let ((reply-headers message-reply-headers)
- (buffer (current-buffer)))
- (with-temp-file buffer-file-name
- (insert-buffer buffer)
- (setq message-reply-headers reply-headers)
- (message-generate-headers '((optional . In-Reply-To)))
- (mime-edit-translate-buffer))
- (set-buffer-modified-p nil))
- (message "Saving %s...done" buffer-file-name))
-
(provide 'message)
(run-hooks 'message-load-hook)
projects / elisp / gnus.git- / blobdiff