;;; message.el --- composing mail and news messages
-;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000
+;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
(eval-when-compile
(require 'cl)
(require 'smtp)
- )
+ (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary
(require 'mailheader)
(require 'nnheader)
-(require 'easymenu)
-(require 'custom)
-(if (string-match "XEmacs\\|Lucid" emacs-version)
- (require 'mail-abbrevs)
- (require 'mailabbrev))
+;; This is apparently necessary even though things are autoloaded:
+(if (featurep 'xemacs)
+ (require 'mail-abbrevs))
(require 'mime-edit)
+(eval-when-compile (require 'static))
;; Avoid byte-compile warnings.
(eval-when-compile
(require 'mail-parse)
- (require 'mm-bodies)
- (require 'mm-encode)
- (require 'mml)
- )
+ (require 'mml))
(defgroup message '((user-mail-address custom-variable)
(user-full-name custom-variable))
:group 'message-headers)
(defcustom message-syntax-checks nil
- ; Guess this one shouldn't be easy to customize...
+ ;; Guess this one shouldn't be easy to customize...
"*Controls what syntax checks should not be performed on outgoing posts.
To disable checking of long signatures, for instance, add
`(signature . disabled)' to this list.
Don't touch this variable unless you really know what you're doing.
Checks include subject-cmsg multiple-headers sendsys message-id from
-long-lines control-chars size new-text redirected-followup signature
-approved sender empty empty-headers message-id from subject
-shorten-followup-to existing-newsgroups buffer-file-name unchanged."
- :group 'message-news)
+long-lines control-chars size new-text quoting-style
+redirected-followup signature approved sender empty empty-headers
+message-id from subject shorten-followup-to existing-newsgroups
+buffer-file-name unchanged newsgroups."
+ :group 'message-news
+ :type '(repeat sexp))
(defcustom message-required-news-headers
'(From Newsgroups Subject Date Message-ID
: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:"
+(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:"
"*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."
:type 'regexp
:group 'message-various)
-(defcustom message-elide-elipsis "\n[...]\n\n"
+(defcustom message-elide-ellipsis "\n[...]\n\n"
"*The string which is inserted for elided text."
:type 'string
:group 'message-various)
:group 'message-forwarding
:type 'string)
-(defcustom message-signature-before-forwarded-message t
- "*If non-nil, put the signature before any included forwarded message."
- :group 'message-forwarding
- :type 'boolean)
-
(defcustom message-included-forward-headers
"^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^\\(Mail-\\)?Followup-To:\\|^\\(Mail-\\)?Reply-To:\\|^Mail-Copies-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-\\|^MIME-Version:"
"*Regexp matching headers to be included in forwarded messages."
(defcustom message-make-forward-subject-function
'message-forward-subject-author-subject
- "*A list of functions that are called to generate a subject header for forwarded messages.
+ "*A list of functions that are called to generate a subject header for forwarded messages.
The subject generated by the previous function is passed into each
successive function.
newsgroup)), in brackets followed by the subject
* message-forward-subject-fwd (Subject of article with 'Fwd:' prepended
to it."
- :group 'message-forwarding
- :type '(radio (function-item message-forward-subject-author-subject)
- (function-item message-forward-subject-fwd)))
+ :group 'message-forwarding
+ :type '(radio (function-item message-forward-subject-author-subject)
+ (function-item message-forward-subject-fwd)))
+
+(defcustom message-forward-as-mime t
+ "*If non-nil, forward messages as an inline/rfc822 MIME section. Otherwise, directly inline the old message in the forwarded message."
+ :group 'message-forwarding
+ :type 'boolean)
+
+(defcustom message-forward-show-mml t
+ "*If non-nil, forward messages are shown as mml. Otherwise, forward messages are unchanged."
+ :group 'message-forwarding
+ :type 'boolean)
+
+(defcustom message-forward-before-signature t
+ "*If non-nil, put forwarded message before signature, else after."
+ :group 'message-forwarding
+ :type 'boolean)
(defcustom message-wash-forwarded-subjects nil
"*If non-nil, try to remove as much old cruft as possible from the subject of messages before generating the new subject of a forward."
:group 'message-interface
:type 'regexp)
+(defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus"
+ "*All headers that match this regexp will be deleted when forwarding a message."
+ :group 'message-forwarding
+ :type '(choice (const :tag "None" nil)
+ regexp))
+
(defcustom message-ignored-cited-headers "."
"*Delete these headers from the messages you yank."
:group 'message-insertion
:type 'regexp)
-(defcustom message-cancel-message "I am canceling my own article."
+(defcustom message-cite-prefix-regexp
+ ;; ?-, ?_ or ?. MUST NOT be in syntax entry w.
+ "[ \t]*\\(\\(\\w\\|[-_.]\\)+>+[ \t]*\\|[]>ยป|:}+][ \t]*\\)+"
+ "*Regexp matching the longest possible citation prefix on a line."
+ :group 'message-insertion
+ :type 'regexp)
+
+(defcustom message-cancel-message "I am canceling my own article.\n"
"Message to be inserted in the cancel message."
:group 'message-interface
:type 'string)
(const :tag "always" use)
(const :tag "ask" ask)))
-;; stuff relating to broken sendmail in MMDF
(defcustom message-sendmail-f-is-evil nil
- "*Non-nil means that \"-f username\" should not be added to the sendmail
-command line, because it is even more evil than leaving it out."
+ "*Non-nil means that \"-f username\" should not be added to the sendmail command line.
+Doing so would be even more evil than leaving it out."
:group 'message-sending
:type 'boolean)
:group 'message-sending
:type '(repeat string))
+(defvar message-cater-to-broken-inn t
+ "Non-nil means Gnus should not fold the `References' header.
+Folding `References' makes ancient versions of INN create incorrect
+NOV lines.")
+
(defvar gnus-post-method)
(defvar gnus-select-method)
(defcustom message-post-method
:group 'message-various
:type 'hook)
-(defcustom message-header-hook '(eword-encode-header)
+(defcustom message-header-hook '((lambda () (eword-encode-header t)))
"Hook run in a message mode buffer narrowed to the headers."
:group 'message-various
:type 'hook)
:group 'message-insertion)
(defcustom message-yank-add-new-references t
- "*Non-nil means new IDs will be added to \"References\" field when an
-article is yanked by the command `message-yank-original' interactively."
- :type 'boolean
+ "Non-nil means new IDs will be added to \"References\" field when an
+article is yanked by the command `message-yank-original' interactively.
+If it is a symbol `message-id-only', only an ID from \"Message-ID\" field
+is used, otherwise IDs extracted from \"References\", \"In-Reply-To\" and
+\"Message-ID\" fields are used."
+ :type '(radio (const :tag "Do not add anything" nil)
+ (const :tag "From Message-Id, References and In-Reply-To fields" t)
+ (const :tag "From only Message-Id field." message-id-only))
+ :group 'message-insertion)
+
+(defcustom message-list-references-add-position nil
+ "Integer value means position for adding to \"References\" field when
+an article is yanked by the command `message-yank-original' interactively."
+ :type '(radio (const :tag "Add to last" nil)
+ (integer :tag "Position from last ID"))
:group 'message-insertion)
(defcustom message-indentation-spaces 3
Note that `message-cite-original' uses `mail-citation-hook' if that is non-nil."
:type '(radio (function-item message-cite-original)
(function-item message-cite-original-without-signature)
+ (function-item mu-cite-original)
(function-item sc-cite-original)
(function :tag "Other"))
:group 'message-insertion)
:type 'message-header-lines)
(defcustom message-default-news-headers ""
- "*A string of header lines to be inserted in outgoing news
-articles."
+ "*A string of header lines to be inserted in outgoing news articles."
:group 'message-headers
:group 'message-news
:type 'message-header-lines)
(defvar message-user-agent nil
"String of the form of PRODUCT/VERSION. Used for User-Agent header field.")
-;; Ignore errors in case this is used in Emacs 19.
-;; Don't use ignore-errors because this is copied into loaddefs.el.
+(static-when (boundp 'MULE)
+ (require 'reporter));; `define-mail-user-agent' is here.
+
;;;###autoload
-(ignore-errors
- (define-mail-user-agent 'message-user-agent
- 'message-mail 'message-send-and-exit
- 'message-kill-buffer 'message-send-hook))
+(define-mail-user-agent 'message-user-agent
+ 'message-mail 'message-send-and-exit
+ 'message-kill-buffer 'message-send-hook)
(defvar message-mh-deletable-headers '(Message-ID Date Lines Sender)
"If non-nil, delete the deletable headers before feeding to mh.")
:type '(choice (const :tag "unique" unique)
(const :tag "unsent" unsent)))
-(defcustom message-default-charset nil
+(defcustom message-default-charset
+ (and (featurep 'xemacs) (not (featurep 'mule)) 'iso-8859-1)
"Default charset used in non-MULE XEmacsen."
:group 'message
:type 'symbol)
+(defcustom message-dont-reply-to-names
+ (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names)
+ "*A regexp specifying names to prune when doing wide replies.
+A value of nil means exclude your own name only."
+ :group 'message
+ :type '(choice (const :tag "Yourself" nil)
+ regexp))
+
;;; Internal variables.
;;; Well, not really internal.
"Face used for displaying MML."
:group 'message-faces)
-(defvar message-font-lock-keywords
- (let* ((cite-prefix "A-Za-z")
- (cite-suffix (concat cite-prefix "0-9_.@-"))
- (content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)"))
+(defvar message-font-lock-fence-open-regexp "[+|]"
+ "*Regexp that matches fence open string.")
+
+(defvar message-font-lock-fence-close-regexp "|"
+ "*Regexp that matches fence close string.")
+
+(defvar message-font-lock-fence-open-position nil
+ "*Cons of SYMBOL of a function or a variable and a number of OFFSET that
+indicate the fence open position. If it is non-nil,
+`message-font-lock-fence-open-regexp' is not used for searching for the
+fence open position. If SYMBOL is a function, it is called with one argument
+last cursor position and should return the fence open position as a number
+or a marker. If SYMBOL is a variable symbol, the value is examined with
+`symbol-value'. OFFSET is added to the position to compensate the value.
+For example, the following combinations of variable symbol and offset value
+can be used:
+
+Egg v3: '(egg:*region-start* . -1)
+Canna: '(canna:*region-start* . 0)
+")
+
+(defvar message-font-lock-fence-close-position nil
+ "*Cons of SYMBOL of a function or a variable and a number of OFFSET that
+indicate the fence close position. If it is non-nil,
+`message-font-lock-fence-close-regexp' is not used for searching for the
+fence close position. If SYMBOL is a function, it is called with one argument
+last cursor position and should return the fence close position as a number
+or a marker. If SYMBOL is a variable symbol, the value is examined with
+`symbol-value'. OFFSET is added to the position to compensate the value.
+For example, the following combinations of variable symbol and offset value
+can be used:
+
+Egg v3: '(egg:*region-end* . 0)
+Canna: '(canna:*region-end* . 0)
+")
+
+(defvar message-font-lock-cited-text-regexp
+ "^[\t ]*\\([^\000- :>|}\177]*\\)[:>|}].*"
+ "*Regexp that matches cited text. It should have a grouping for the
+citation prefix which is ended at the beginning of citation mark string.")
+
+(defvar message-font-lock-citation-name-max-column 10
+ "*Maximun number of column for citation name for fontifying.")
+
+(defvar message-font-lock-last-position nil
+ "Internal buffer local variable to save the last cursor position
+before fontifying.")
+
+(eval-after-load "font-lock"
+ '(defadvice font-lock-after-change-function
+ (before message-font-lock-save-last-position activate)
+ "Save last cursor position before fontifying."
+ (if (eq 'message-mode major-mode)
+ (setq message-font-lock-last-position (point)))))
+
+(defun message-font-lock-cited-text-matcher (limit)
+ "Search for a cited text containing `message-font-lock-cited-text-regexp'
+forward. Argument LIMIT bounds the search. If a cited text is found, it
+returns t and sets match data 1 and 2, otherwise it returns nil. Normally,
+match data 2 has zero length, but if the FENCE (for input method) is detected
+in matched text, result is divided into match data 1 and 2 across the FENCE.
+See also the documentations for the following variables:
+ `message-font-lock-fence-open-regexp'
+ `message-font-lock-fence-close-regexp'
+ `message-font-lock-fence-open-position'
+ `message-font-lock-fence-close-position'
+"
+ (prog1
+ (when (re-search-forward message-font-lock-cited-text-regexp limit t)
+ (let* ((start0 (match-beginning 0))
+ (end0 (match-end 0))
+ (cite-mark (match-end 1))
+ (should-fontify
+ (progn
+ (goto-char cite-mark)
+ (<= (current-column)
+ message-font-lock-citation-name-max-column)))
+ end1 start2)
+ (and
+ should-fontify
+ message-font-lock-last-position
+ (>= message-font-lock-last-position start0)
+ (<= message-font-lock-last-position end0)
+ (cond
+ (message-font-lock-fence-open-position
+ (let* ((symbol (car message-font-lock-fence-open-position))
+ (open
+ (cond ((functionp symbol)
+ (funcall symbol message-font-lock-last-position))
+ ((and (symbolp symbol)
+ (boundp symbol))
+ (symbol-value symbol)))))
+ (when (markerp open)
+ (setq open (marker-position open)))
+ (and (numberp open)
+ (setq open
+ (+ open
+ (cdr message-font-lock-fence-open-position)))
+ (>= message-font-lock-last-position open)
+ (goto-char open)
+ (or (not message-font-lock-fence-open-regexp)
+ (looking-at message-font-lock-fence-open-regexp))
+ (setq end1 open))))
+ (message-font-lock-fence-open-regexp
+ (goto-char message-font-lock-last-position)
+ (when (re-search-backward
+ message-font-lock-fence-open-regexp start0 t)
+ (setq end1 (match-beginning 0)))))
+ (setq should-fontify
+ (and message-font-lock-fence-open-position
+ (not (eq cite-mark end1))))
+ (cond
+ (message-font-lock-fence-close-position
+ (let* ((symbol (car message-font-lock-fence-close-position))
+ (close
+ (cond ((functionp symbol)
+ (funcall symbol message-font-lock-last-position))
+ ((and (symbolp symbol)
+ (boundp symbol))
+ (symbol-value symbol)))))
+ (when (markerp close)
+ (setq close (marker-position close)))
+ (and (numberp close)
+ (setq close
+ (+ close
+ (cdr message-font-lock-fence-close-position)))
+ (<= message-font-lock-last-position close)
+ (setq start2 close))))
+ (message-font-lock-fence-close-regexp
+ (goto-char message-font-lock-last-position)
+ (when (looking-at message-font-lock-fence-close-regexp)
+ (setq start2 (match-end 0)))))
+ (setq should-fontify
+ (and (not (and (not message-font-lock-fence-open-position)
+ (eq cite-mark end1)))
+ (not (eq cite-mark start2)))))
+ (goto-char end0)
+ (when should-fontify
+ (if start2
+ (store-match-data (list start0 end0 start0 end1 start2 end0))
+ (store-match-data (list start0 end0 start0 end0 end0 end0)))
+ t)))
+ (setq message-font-lock-last-position nil)))
+
+(defvar message-font-lock-keywords-1
+ (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?"))
`((,(concat "^\\([Tt]o:\\)" content)
(1 'message-header-name-face)
(2 'message-header-to-face nil t))
(not (equal mail-header-separator "")))
`((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
1 'message-separator-face))
- nil)
- (,(concat "^[ \t]*"
- "\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
- "[:>|}].*")
- (0 'message-cited-text-face))
- ("<#/?\\(multipart\\|part\\|external\\).*>"
- (0 'message-mml-face))))
+ nil))))
+
+(defvar message-font-lock-keywords-2
+ (append message-font-lock-keywords-1
+ `((message-font-lock-cited-text-matcher
+ (1 'message-cited-text-face)
+ (2 'message-cited-text-face))
+ (,(concat "^\\(" message-cite-prefix-regexp "\\).*")
+ (0 'message-cited-text-face))
+ ("<#/?\\(multipart\\|part\\|external\\|mml\\).*>"
+ (0 'message-mml-face)))))
+
+(defvar message-font-lock-keywords message-font-lock-keywords-2
"Additional expressions to highlight in Message mode.")
;; XEmacs does it like this. For Emacs, we have to set the
;; `font-lock-defaults' buffer-local variable.
-(put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t))
+(put 'message-mode 'font-lock-defaults
+ '((message-font-lock-keywords
+ message-font-lock-keywords-1
+ message-font-lock-keywords-2)
+ nil nil nil nil
+ (font-lock-mark-block-function . mark-paragraph)))
(defvar message-face-alist
'((bold . bold-region)
(defvar message-draft-coding-system
(cond
+ ((boundp 'MULE) '*junet*)
((not (fboundp 'find-coding-system)) nil)
- ((find-coding-system 'emacs-mule) 'emacs-mule)
+ ((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))
"Coding system to compose mail.")
+(defcustom message-send-mail-partially-limit 1000000
+ "The limitation of messages sent as message/partial.
+The lower bound of message size in characters, beyond which the message
+should be sent in several parts. If it is nil, the size is unlimited."
+ :group 'message-buffers
+ :type '(choice (const :tag "unlimited" nil)
+ (integer 1000000)))
+
+(defcustom message-alternative-emails nil
+ "A regexp to match the alternative email addresses.
+The first matched address (not primary one) is used in the From field."
+ :group 'message-headers
+ :type '(choice (const :tag "Always use primary" nil)
+ regexp))
+
;;; Internal variables.
+(defvar message-sending-message "Sending...")
(defvar message-buffer-list nil)
(defvar message-this-is-news nil)
(defvar message-this-is-mail nil)
"\\([^\0-\b\n-\r\^?].*\\)? "
;; The time the message was sent.
- "\\([^\0-\r \^?]+\\) +" ; day of the week
- "\\([^\0-\r \^?]+\\) +" ; month
- "\\([0-3]?[0-9]\\) +" ; day of month
- "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day
+ "\\([^\0-\r \^?]+\\) +" ; day of the week
+ "\\([^\0-\r \^?]+\\) +" ; month
+ "\\([0-3]?[0-9]\\) +" ; day of month
+ "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day
;; Perhaps a time zone, specified by an abbreviation, or by a
;; numeric offset.
"^ *---+ +Original message +---+ *$\\|"
"^ *--+ +begin message +--+ *$\\|"
"^ *---+ +Original message follows +---+ *$\\|"
+ "^ *---+ +Undelivered message follows +---+ *$\\|"
"^|? *---+ +Message text follows: +---+ *|?$")
"A regexp that matches the separator before the text of a failed message.")
(User-Agent))
"Alist used for formatting headers.")
+(defvar message-options nil
+ "Some saved answers when sending message.")
+
(eval-and-compile
(autoload 'message-setup-toolbar "messagexmas")
(autoload 'mh-new-draft-name "mh-comp")
(autoload 'mh-send-letter "mh-comp")
(autoload 'gnus-point-at-eol "gnus-util")
(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 'gnus-request-post "gnus-int")
(autoload 'gnus-copy-article-buffer "gnus-msg")
(autoload 'gnus-alive-p "gnus-util")
- (autoload 'rmail-output "rmail"))
+ (autoload 'gnus-group-name-charset "gnus-group")
+ (autoload 'rmail-output "rmail")
+ (autoload 'mu-cite-original "mu-cite"))
\f
`(delete-region (progn (beginning-of-line) (point))
(progn (forward-line ,(or n 1)) (point))))
+(defun message-unquote-tokens (elems)
+ "Remove double quotes (\") from strings in list."
+ (mapcar (lambda (item)
+ (while (string-match "^\\(.*\\)\"\\(.*\\)$" item)
+ (setq item (concat (match-string 1 item)
+ (match-string 2 item))))
+ item)
+ elems))
+
(defun message-tokenize-header (header &optional separator)
"Split HEADER into a list of header elements.
-\",\" is used as the separator."
+SEPARATOR is a string of characters to be used as separators. \",\"
+is used by default."
(if (not header)
nil
(let ((regexp (format "[%s]+" (or separator ",")))
((and (eq (char-after) ?\))
(not quoted))
(setq paren nil))))
- (nreverse elems)))))
+ (nreverse elems)))))
(defun message-mail-file-mbox-p (file)
"Say whether FILE looks like a Unix mbox file."
(defun message-fetch-field (header &optional not-all)
"The same as `mail-fetch-field', only remove all newlines."
(let* ((inhibit-point-motion-hooks t)
+ (case-fold-search t)
(value (mail-fetch-field header nil (not not-all))))
(when value
(while (string-match "\n[\t ]+" value)
(setq value (replace-match " " t t value)))
- ;; We remove all text props.delete-region
- (format "%s" value))))
+ (set-text-properties 0 (length value) nil value)
+ value)))
(defun message-narrow-to-field ()
"Narrow the buffer to the header on the current line."
(unless (string-match "^\\([^:]+\\):[ \t]*[^ \t]" (car headers))
(error "Invalid header `%s'" (car headers)))
(setq hclean (match-string 1 (car headers)))
- (save-restriction
- (message-narrow-to-headers)
- (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t)
- (insert (car headers) ?\n))))
+ (save-restriction
+ (message-narrow-to-headers)
+ (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t)
+ (insert (car headers) ?\n))))
(setq headers (cdr headers))))
+
(defun message-fetch-reply-field (header)
"Fetch FIELD from the message we're replying to."
(let ((buffer (message-eval-parameter message-reply-buffer)))
(and (listp form) (eq (car form) 'lambda))
(byte-code-function-p form)))
+(defun message-strip-list-identifiers (subject)
+ "Remove list identifiers in `gnus-list-identifiers'."
+ (require 'gnus-sum) ; for gnus-list-identifiers
+ (let ((regexp (if (stringp gnus-list-identifiers)
+ gnus-list-identifiers
+ (mapconcat 'identity gnus-list-identifiers " *\\|"))))
+ (if (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp
+ " *\\)\\)+\\(Re: +\\)?\\)") subject)
+ (concat (substring subject 0 (match-beginning 1))
+ (or (match-string 3 subject)
+ (match-string 5 subject))
+ (substring subject
+ (match-end 1)))
+ subject)))
+
(defun message-strip-subject-re (subject)
"Remove \"Re:\" from subject lines."
(if (string-match message-subject-re-regexp subject)
(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-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-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-q" 'message-fill-yanked-message)
(define-key message-mode-map "\C-c\C-w" 'message-insert-signature)
(define-key message-mode-map "\C-c\M-h" 'message-insert-headers)
C-c C-e message-elide-region (elide the text between point and mark).
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-r message-caesar-buffer-body (rot13 the message body).
+M-RET message-newline-and-reformat (break the line and reformat)."
(interactive)
(kill-all-local-variables)
(set (make-local-variable 'message-reply-buffer) nil)
(error "Face %s not configured for %s mode" face mode-name)))
"")
facemenu-remove-face-function t)
- (make-local-variable 'paragraph-separate)
- (make-local-variable 'paragraph-start)
- ;; `-- ' precedes the signature. `-----' appears at the start of the
- ;; lines that delimit forwarded messages.
- ;; Lines containing just >= 3 dashes, perhaps after whitespace,
- ;; are also sometimes used and should be separators.
- (setq paragraph-start
- (concat (regexp-quote mail-header-separator)
- "$\\|[ \t]*[a-z0-9A-Z]*>+[ \t]*$\\|[ \t]*$\\|"
- "-- $\\|---+$\\|"
- page-delimiter
- ;;!!! Uhm... shurely this can't be right?
- "[> " (regexp-quote message-yank-prefix) "]+$"))
- (setq paragraph-separate paragraph-start)
(make-local-variable 'message-reply-headers)
(setq message-reply-headers nil)
(make-local-variable 'message-user-agent)
(make-local-variable 'message-parameter-alist)
(setq message-parameter-alist
(copy-sequence message-startup-parameter-alist))
+ (message-setup-fill-variables)
;;(when (fboundp 'mail-hist-define-keys)
;; (mail-hist-define-keys))
- (when (string-match "XEmacs\\|Lucid" emacs-version)
- (message-setup-toolbar))
+ (if (featurep 'xemacs)
+ (message-setup-toolbar)
+ (set (make-local-variable 'font-lock-defaults)
+ '((message-font-lock-keywords
+ message-font-lock-keywords-1
+ message-font-lock-keywords-2)
+ nil nil nil nil
+ (font-lock-mark-block-function . mark-paragraph))))
+ (set (make-local-variable 'message-font-lock-last-position) nil)
(easy-menu-add message-mode-menu message-mode-map)
(easy-menu-add message-mode-field-menu message-mode-map)
;; Allow mail alias things.
(mail-abbrevs-setup)
(mail-aliases-setup)))
(message-set-auto-save-file-name)
- (unless (string-match "XEmacs" emacs-version)
- (set (make-local-variable 'font-lock-defaults)
- '(message-font-lock-keywords t)))
+ (make-local-variable 'indent-tabs-mode) ;Turn off tabs for indentation.
+ (setq indent-tabs-mode nil)
+ (run-hooks 'text-mode-hook 'message-mode-hook))
+
+(defun message-setup-fill-variables ()
+ "Setup message fill variables."
+ (make-local-variable 'paragraph-separate)
+ (make-local-variable 'paragraph-start)
(make-local-variable 'adaptive-fill-regexp)
- (setq adaptive-fill-regexp
- (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|" adaptive-fill-regexp))
(unless (boundp 'adaptive-fill-first-line-regexp)
(setq adaptive-fill-first-line-regexp nil))
(make-local-variable 'adaptive-fill-first-line-regexp)
- (setq adaptive-fill-first-line-regexp
- (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|"
- adaptive-fill-first-line-regexp))
- (make-local-variable 'indent-tabs-mode) ;Turn off tabs for indentation.
- (setq indent-tabs-mode nil)
- (run-hooks 'text-mode-hook 'message-mode-hook))
+ (make-local-variable 'auto-fill-inhibit-regexp)
+ (let ((quote-prefix-regexp
+ (concat
+ "[ \t]*" ; possible initial space
+ "\\(\\(" (regexp-quote message-yank-prefix) "\\|" ; user's prefix
+ "\\(\\w\\|[-_.]\\)+>\\|" ; supercite-style prefix
+ "[|:>]" ; standard prefix
+ "\\)[ \t]*\\)+"))) ; possible space after each prefix
+ (setq paragraph-start
+ (concat
+ (regexp-quote mail-header-separator) "$\\|"
+ "[ \t]*$\\|" ; blank lines
+ "-- $\\|" ; signature delimiter
+ "---+$\\|" ; delimiters for forwarded messages
+ page-delimiter "$\\|" ; spoiler warnings
+ ".*wrote:$\\|" ; attribution lines
+ quote-prefix-regexp "$")) ; empty lines in quoted text
+ (setq paragraph-separate paragraph-start)
+ (setq adaptive-fill-regexp
+ (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]+:")))
\f
(message-position-on-field "Mail-Reply-To" "Subject"))
(defun message-goto-mail-followup-to ()
- "Move point to the Mail-Followup-To header."
+ "Move point to the Mail-Followup-To header. If the header is newly created
+and To field contains only one address, the address is inserted in default."
(interactive)
- (message-position-on-field "Mail-Followup-To" "Subject"))
+ (unless (message-position-on-field "Mail-Followup-To" "Subject")
+ (let ((start (point))
+ addresses)
+ (save-restriction
+ (message-narrow-to-headers)
+ (setq addresses (split-string (mail-strip-quoted-names
+ (or (std11-fetch-field "to") ""))
+ "[ \f\t\n\r\v,]+"))
+ (when (eq 1 (length addresses))
+ (goto-char start)
+ (insert (car addresses))
+ (goto-char start))))))
(defun message-goto-mail-copies-to ()
- "Move point to the Mail-Copies-To header."
+ "Move point to the Mail-Copies-To header. If the header is newly created,
+a string \"never\" is inserted in default."
(interactive)
- (message-position-on-field "Mail-Copies-To" "Subject"))
+ (unless (message-position-on-field "Mail-Copies-To" "Subject")
+ (insert "never")
+ (backward-char 5)))
(defun message-goto-newsgroups ()
"Move point to the Newsgroups header."
"Move point to the end of the headers."
(interactive)
(message-goto-body)
- (forward-line -2))
+ (forward-line -1))
(defun message-goto-signature ()
"Move point to the beginning of the message signature.
(mail-fetch-field "to")
(not (string-match "\\` *\\'" (mail-fetch-field "to"))))
(insert ", "))
- (insert (or (message-fetch-reply-field "reply-to")
+ (insert (or (message-fetch-reply-field "mail-reply-to")
+ (message-fetch-reply-field "reply-to")
(message-fetch-reply-field "from") "")))
+(defun message-widen-reply ()
+ "Widen the reply to include maximum recipients."
+ (interactive)
+ (let ((follow-to
+ (and message-reply-buffer
+ (buffer-name message-reply-buffer)
+ (save-excursion
+ (set-buffer message-reply-buffer)
+ (message-get-reply-headers t)))))
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (dolist (elem follow-to)
+ (message-remove-header (symbol-name (car elem)))
+ (goto-char (point-min))
+ (insert (symbol-name (car elem)) ": "
+ (cdr elem) "\n"))))))
+
(defun message-insert-newsgroups ()
"Insert the Newsgroups header from the article being replied to."
(interactive)
(defun message-newline-and-reformat ()
"Insert four newlines, and then reformat if inside quoted text."
(interactive)
- (let ((point (point))
- quoted)
- (save-excursion
- (beginning-of-line)
- (setq quoted (looking-at (regexp-quote message-yank-prefix))))
- (insert "\n\n\n\n")
+ (let (quoted point)
+ (unless (bolp)
+ (save-excursion
+ (beginning-of-line)
+ (when (looking-at message-cite-prefix-regexp)
+ (setq quoted (match-string 0))))
+ (insert "\n"))
+ (setq point (point))
+ (insert "\n\n\n")
+ (delete-region (point) (re-search-forward "[ \t]*"))
(when quoted
- (insert message-yank-prefix))
+ (insert quoted))
(fill-paragraph nil)
(goto-char point)
- (forward-line 2)))
+ (forward-line 1)))
(defun message-insert-signature (&optional force)
"Insert a signature. See documentation for the `message-signature' variable."
(defun message-elide-region (b e)
"Elide the text between point and mark.
-An ellipsis (from `message-elide-elipsis') will be inserted where the
+An ellipsis (from `message-elide-ellipsis') will be inserted where the
text was killed."
(interactive "r")
(kill-region b e)
- (unless (bolp)
- (insert "\n"))
- (insert message-elide-elipsis))
+ (insert message-elide-ellipsis))
(defvar message-caesar-translation-table nil)
;; We build the table, if necessary.
(when (or (not message-caesar-translation-table)
(/= (aref message-caesar-translation-table ?a) (+ ?a n)))
- (setq message-caesar-translation-table
- (message-make-caesar-translation-table n)))
- ;; Then we translate the region. Do it this way to retain
- ;; text properties.
- (while (< b e)
- (when (< (char-after b) 255)
- (subst-char-in-region
- b (1+ b) (char-after b)
- (aref message-caesar-translation-table (char-after b))))
- (incf b))))
+ (setq message-caesar-translation-table
+ (message-make-caesar-translation-table n)))
+ (translate-region b e message-caesar-translation-table)))
(defun message-make-caesar-translation-table (n)
"Create a rot table with offset N."
(save-restriction
(when (message-goto-body)
(narrow-to-region (point) (point-max)))
- (let ((body (buffer-substring (point-min) (point-max))))
- (unless (equal 0 (call-process-region
- (point-min) (point-max) program t t))
- (insert body)
- (message "%s failed." program))))))
+ (shell-command-on-region
+ (point-min) (point-max) program nil t))))
(defun message-rename-buffer (&optional enter-string)
"Rename the *message* buffer to \"*message* RECIPIENT\".
(goto-char (point-min))
(search-forward (concat "\n" mail-header-separator "\n") nil t)
(let ((fill-prefix message-yank-prefix))
- (fill-individual-paragraphs (point) (point-max) justifyp t))))
+ (fill-individual-paragraphs (point) (point-max) justifyp))))
(defun message-indent-citation ()
"Modify text just inserted from a message to be cited.
(message-delete-line))
;; Delete blank lines at the end of the buffer.
(goto-char (point-max))
- (unless (eolp)
+ (unless (bolp)
(insert "\n"))
(while (and (zerop (forward-line -1))
(looking-at "$"))
(defun message-list-references (refs-list &rest refs-strs)
"Add `Message-ID's which appear in REFS-STRS but not in REFS-LIST,
to REFS-LIST."
- (let (refs ref id)
+ (let (refs ref id saved-id)
+ (when (and refs-list
+ (integerp message-list-references-add-position))
+ (let ((pos message-list-references-add-position))
+ (while (and refs-list
+ (> pos 0))
+ (push (pop refs-list) saved-id)
+ (setq pos (1- pos)))))
(while refs-strs
- (setq refs (car refs-strs)
- refs-strs (cdr refs-strs))
- (when refs
+ (when (setq refs (pop refs-strs))
(setq refs (std11-parse-msg-ids (std11-lexical-analyze refs)))
(while refs
- (setq ref (car refs)
- refs (cdr refs))
- (when (eq (car ref) 'msg-id)
- (setq id (concat "<"
- (mapconcat
- (function (lambda (p) (cdr p)))
- (cdr ref) "")
- ">"))
+ (when (eq (car (setq ref (pop refs))) 'msg-id)
+ (setq id (concat "<" (mapconcat 'cdr (cdr ref) "") ">"))
(or (member id refs-list)
+ (member id saved-id)
(push id refs-list))))))
+ (while saved-id
+ (push (pop saved-id) refs-list))
refs-list))
(defvar gnus-article-copy)
In addition, if `message-yank-add-new-references' is non-nil and this
command is called interactively, new IDs from the yanked article will
-be added to \"References\" field."
+be added to \"References\" field.
+\(See also `message-yank-add-new-references'.)"
(interactive "P")
(let ((modified (buffer-modified-p))
(buffer (message-eval-parameter message-reply-buffer))
(std11-narrow-to-header)
(when (setq refs (message-list-references
refs
- (or (message-fetch-field "References")
- (message-fetch-field "In-Reply-To"))
+ (unless (eq message-yank-add-new-references
+ 'message-id-only)
+ (or (message-fetch-field "References")
+ (message-fetch-field "In-Reply-To")))
(message-fetch-field "Message-ID")))
(widen)
(message-narrow-to-headers)
(unless modified
(setq message-checksum (message-checksum))))))
+(defun message-yank-buffer (buffer)
+ "Insert BUFFER into the current buffer and quote it."
+ (interactive "bYank buffer: ")
+ (let ((message-reply-buffer buffer))
+ (save-window-excursion
+ (message-yank-original))))
+
+(defun message-buffers ()
+ "Return a list of active message buffers."
+ (let (buffers)
+ (save-excursion
+ (dolist (buffer (buffer-list t))
+ (set-buffer buffer)
+ (when (and (eq major-mode 'message-mode)
+ (null message-sent-message-via))
+ (push (buffer-name buffer) buffers))))
+ (nreverse buffers)))
+
(defun message-cite-original-without-signature ()
"Cite function in the standard Message manner."
(let ((start (point))
(if (listp message-indent-citation-function)
message-indent-citation-function
(list message-indent-citation-function)))))
+ ;; Allow undoing.
+ (undo-boundary)
(goto-char end)
(when (re-search-backward message-signature-separator start t)
;; Also peel off any blank lines before the signature.
(when message-indent-citation-function
(if (listp message-indent-citation-function)
message-indent-citation-function
- (list message-indent-citation-function)))))
+ (list message-indent-citation-function))))
+ (message-reply-headers (or message-reply-headers
+ (make-mail-header))))
+ (mail-header-set-from message-reply-headers
+ (save-restriction
+ (narrow-to-region
+ (point)
+ (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (point-max)))
+ (or (message-fetch-field "from")
+ "unknown sender")))
(goto-char start)
(while functions
(funcall (pop functions)))
(defun message-delete-frame (frame org-frame)
"Delete frame for editing message."
- (when (and (or (and (featurep 'xemacs)
- (not (eq 'tty (device-type))))
- window-system
+ (when (and (or (static-if (featurep 'xemacs)
+ (device-on-window-system-p)
+ window-system)
(>= emacs-major-version 20))
(or (and (eq message-delete-frame-on-exit t)
(select-frame frame)
(defun message-send (&optional arg)
"Send the message in the current buffer.
-If `message-interactive' is non-nil, wait for success indication
-or error messages, and inform user.
-Otherwise any failure is reported in a message back to
-the user from the mailer."
+If `message-interactive' is non-nil, wait for success indication or
+error messages, and inform user.
+Otherwise any failure is reported in a message back to the user from
+the mailer.
+The usage of ARG is defined by the instance that called Message.
+It should typically alter the sending method in some way or other."
(interactive "P")
;; Disabled test.
(when (or (buffer-modified-p)
(let ((inhibit-read-only t))
(put-text-property (point-min) (point-max) 'read-only nil))
(run-hooks 'message-send-hook)
- (message "Sending...")
+ (message-fix-before-sending)
+ (message message-sending-message)
(let ((message-encoding-buffer
(message-generate-new-buffer-clone-locals " message encoding"))
(message-edit-buffer (current-buffer))
(message-mime-mode mime-edit-mode-flag)
(alist message-send-method-alist)
(success t)
- elem sent)
+ elem sent
+ (message-options message-options))
+ (message-options-set-recipient)
(save-excursion
(set-buffer message-encoding-buffer)
(erase-buffer)
(insert-buffer message-edit-buffer)
(funcall message-encode-function)
- (message-fix-before-sending)
(while (and success
(setq elem (pop alist)))
- (when (and (or (not (funcall (cadr elem)))
- (and (or (not (memq (car elem)
- message-sent-message-via))
- (y-or-n-p
- (format
- "Already sent message via %s; resend? "
- (car elem))))
- (setq success (funcall (caddr elem) arg)))))
- (setq sent t))))
+ (when (funcall (cadr elem))
+ (when (and (or (not (memq (car elem)
+ message-sent-message-via))
+ (y-or-n-p
+ (format
+ "Already sent message via %s; resend? "
+ (car elem))))
+ (setq success (funcall (caddr elem) arg)))
+ (setq sent t)))))
+ (unless (or sent (not success))
+ (error "No methods specified to send by"))
(prog1
(when (and success sent)
(message-do-fcc)
- ;;(when (fboundp 'mail-hist-put-headers-into-history)
- ;; (mail-hist-put-headers-into-history))
(save-excursion
(run-hooks 'message-sent-hook))
(message "Sending...done")
- ;; Mark the buffer as unmodified and delete autosave.
+ ;; Mark the buffer as unmodified and delete auto-save.
(set-buffer-modified-p nil)
(delete-auto-save-file-if-necessary t)
(message-disassociate-draft)
(put 'message-check 'lisp-indent-function 1)
(put 'message-check 'edebug-form-spec '(form body))
+;; This function will be used by MIME-Edit when inserting invisible parts.
+(defun message-invisible-region (start end)
+ (if (featurep 'xemacs)
+ (if (save-excursion
+ (goto-char start)
+ (eq (following-char) ?\n))
+ (setq start (1+ start)))
+ (if (save-excursion
+ (goto-char (1- end))
+ (eq (following-char) ?\n))
+ (setq end (1- end))))
+ (put-text-property start end 'invisible t)
+ (if (eq 'message-mode major-mode)
+ (put-text-property start end 'message-invisible t)))
+
+(eval-after-load "invisible"
+ '(defalias 'invisible-region 'message-invisible-region))
+
(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.
+ (widen)
(goto-char (point-max))
(unless (bolp)
(insert "\n"))
- ;; Delete all invisible text.
+ ;; Expose all invisible text with the property `message-invisible'.
+ ;; We should believe that the things might be created by MIME-Edit.
+ (let (start)
+ (while (setq start (text-property-any (point-min) (point-max)
+ 'message-invisible t))
+ (remove-text-properties start
+ (or (text-property-not-all start (point-max)
+ 'message-invisible t)
+ (point-max))
+ '(invisible nil message-invisible nil))))
+ ;; Expose all invisible text.
(message-check 'invisible-text
(when (text-property-any (point-min) (point-max) 'invisible t)
(put-text-property (point-min) (point-max) 'invisible nil)
(cadr failure)
(prin1-to-string failure)))))
+(defun message-send-mail-partially ()
+ "Sendmail as message/partial."
+ ;; replace the header delimiter with a blank line
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n"))
+ (replace-match "\n")
+ (run-hooks 'message-send-mail-hook)
+ (let ((p (goto-char (point-min)))
+ (tembuf (message-generate-new-buffer-clone-locals " message temp"))
+ (curbuf (current-buffer))
+ (id (message-make-message-id)) (n 1)
+ plist total header required-mail-headers)
+ (while (not (eobp))
+ (if (< (point-max) (+ p message-send-mail-partially-limit))
+ (goto-char (point-max))
+ (goto-char (+ p message-send-mail-partially-limit))
+ (beginning-of-line)
+ (if (<= (point) p) (forward-line 1))) ;; In case of bad message.
+ (push p plist)
+ (setq p (point)))
+ (setq total (length plist))
+ (push (point-max) plist)
+ (setq plist (nreverse plist))
+ (unwind-protect
+ (save-excursion
+ (setq p (pop plist))
+ (while plist
+ (set-buffer curbuf)
+ (copy-to-buffer tembuf p (car plist))
+ (set-buffer tembuf)
+ (goto-char (point-min))
+ (if header
+ (progn
+ (goto-char (point-min))
+ (narrow-to-region (point) (point))
+ (insert header))
+ (message-goto-eoh)
+ (setq header (buffer-substring (point-min) (point)))
+ (goto-char (point-min))
+ (narrow-to-region (point) (point))
+ (insert header)
+ (message-remove-header "Mime-Version")
+ (message-remove-header "Content-Type")
+ (message-remove-header "Content-Transfer-Encoding")
+ (message-remove-header "Message-ID")
+ (message-remove-header "Lines")
+ (goto-char (point-max))
+ (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"
+ id n total))
+ (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")))
+ (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 message-send-mail-function)))
+ (setq n (+ n 1))
+ (setq p (pop plist))
+ (erase-buffer)))
+ (kill-buffer tembuf))))
+
(defun message-send-mail (&optional arg)
(require 'mail-utils)
- (let ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
- (case-fold-search nil)
- (news (message-news-p))
- failure)
+ (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
+ (case-fold-search nil)
+ (news (message-news-p))
+ (message-this-is-mail t)
+ failure)
(save-restriction
(message-narrow-to-headers)
;; Insert some headers.
;; Remove some headers.
(save-restriction
(message-narrow-to-headers)
+;; We Semi-gnus people have no use for it.
+;; ;; 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.
(or (= (preceding-char) ?\n)
(insert ?\n))
- (when (and news
+ (when
+ (save-restriction
+ (message-narrow-to-headers)
+ (and news
(or (message-fetch-field "cc")
- (message-fetch-field "to")))
+ (message-fetch-field "to"))
+ (let ((ct (mime-read-Content-Type)))
+ (and (eq 'text (cdr (assq 'type ct)))
+ (eq 'plain (cdr (assq 'subtype ct)))))))
(message-insert-courtesy-copy))
(setq failure (message-maybe-split-and-send-mail)))
(kill-buffer tembuf))
(defun message-send-mail-with-sendmail ()
"Send off the prepared buffer with sendmail."
(let ((errbuf (if message-interactive
- (generate-new-buffer " sendmail errors")
+ (message-generate-new-buffer-clone-locals
+ " sendmail errors")
0))
resend-to-addresses delimline)
(let ((case-fold-search t))
;; But some systems are more broken with -f, so
;; we'll let users override this.
(if (null message-sendmail-f-is-evil)
- (list "-f" (user-login-name)))
+ (list "-f" (message-make-address)))
;; These mean "report errors by mail"
;; and "deliver in background".
(if (null message-interactive) '("-oem" "-odb"))
(not (funcall message-send-news-function method)))))
(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))
- (message-syntax-checks
- (if arg
- (cons '(existing-newsgroups . disabled)
- message-syntax-checks)
- message-syntax-checks))
- result)
+ (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
+ (case-fold-search nil)
+ (method (if (message-functionp message-post-method)
+ (funcall message-post-method arg)
+ message-post-method))
+ (group-name-charset (gnus-group-name-charset method ""))
+ (message-syntax-checks
+ (if arg
+ (cons '(existing-newsgroups . disabled)
+ message-syntax-checks)
+ message-syntax-checks))
+ (message-this-is-news t)
+ result)
(save-restriction
(message-narrow-to-headers)
;; Insert some headers.
(message-generate-headers message-required-news-headers)
;; Let the user do all of the above.
(run-hooks 'message-header-hook))
+ (if group-name-charset
+ (setq message-syntax-checks
+ (cons '(valid-newsgroups . disabled)
+ message-syntax-checks)))
(message-cleanup-headers)
(if (not (message-check-news-syntax))
nil
;; Remove some headers.
(save-restriction
(message-narrow-to-headers)
+;; We Semi-gnus people have no use for it.
+;; ;; 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-news-headers t))
(goto-char (point-max))
(defun message-check-news-header-syntax ()
(and
+ ;; Check Newsgroups header.
+ (message-check 'newsgroups
+ (let ((group (message-fetch-field "newsgroups")))
+ (or
+ (and group
+ (not (string-match "\\`[ \t]*\\'" group)))
+ (ignore
+ (message
+ "The newsgroups field is empty or missing. Posting is denied.")))))
;; Check the Subject header.
(message-check 'subject
(let* ((case-fold-search t)
(message-check 'from
(let* ((case-fold-search t)
(from (message-fetch-field "from"))
- (ad (nth 1 (std11-extract-address-components from))))
+ ad)
(cond
((not from)
(message "There is no From line. Posting is denied.")
nil)
- ((or (not (string-match "@[^\\.]*\\." ad)) ;larsi@ifi
+ ((or (not (string-match
+ "@[^\\.]*\\."
+ (setq ad (nth 1 (mail-extract-address-components
+ from))))) ;larsi@ifi
(string-match "\\.\\." ad) ;larsi@ifi..uio
(string-match "@\\." ad) ;larsi@.ifi.uio
(string-match "\\.$" ad) ;larsi@ifi.uio.
(message-check 'signature
(goto-char (point-max))
(if (> (count-lines (point) (point-max)) 5)
- (y-or-n-p
- (format
- "Your .sig is %d lines; it should be max 4. Really post? "
- (1- (count-lines (point) (point-max)))))
- t))))
+ (y-or-n-p
+ (format
+ "Your .sig is %d lines; it should be max 4. Really post? "
+ (1- (count-lines (point) (point-max)))))
+ t))
+ ;; Ensure that text follows last quoted portion.
+ (message-check 'quoting-style
+ (goto-char (point-max))
+ (let ((no-problem t))
+ (when (search-backward-regexp "^>[^\n]*\n>" nil t)
+ (setq no-problem nil)
+ (while (not (eobp))
+ (when (and (not (eolp)) (looking-at "[^> \t]"))
+ (setq no-problem t))
+ (forward-line)))
+ (if no-problem
+ t
+ (y-or-n-p "Your text should follow quoted text. Really post? "))))))
(defun message-check-mail-syntax ()
"Check the syntax of the message."
"Process Fcc headers in the current buffer."
(let ((case-fold-search t)
(coding-system-for-write 'raw-text)
+ (output-coding-system 'raw-text)
list file)
(save-excursion
(set-buffer (get-buffer-create " *message temp*"))
"Append this article to Unix/babyl mail file.."
(if (and (file-readable-p filename)
(mail-file-babyl-p filename))
- (rmail-output-to-rmail-file filename t)
+ (gnus-output-to-rmail filename t)
(gnus-output-to-mail filename t)))
(defun message-cleanup-headers ()
parse-time-months))))
(format-time-string "%Y %H:%M:%S " now)
;; We do all of this because XEmacs doesn't have the %z spec.
- (format "%s%02d%02d" sign (/ zone 3600) (% zone 3600)))))
+ (format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60)))))
(defun message-make-followup-subject (subject)
"Make a followup Subject."
"Make an Organization header."
(let* ((organization
(when message-user-organization
- (if (message-functionp message-user-organization)
- (funcall message-user-organization)
- message-user-organization))))
+ (if (message-functionp message-user-organization)
+ (funcall message-user-organization)
+ message-user-organization))))
(save-excursion
(message-set-work-buffer)
(cond ((stringp organization)
;; The element is a symbol. We insert the value
;; of this symbol, if any.
(symbol-value header))
- (t
+ ((not (message-check-element header))
;; We couldn't generate a value for this header,
;; so we just ask the user.
(read-from-minibuffer
;; This header didn't exist, so we insert it.
(goto-char (point-max))
(insert (if (stringp header) header (symbol-name header))
- ": " value "\n")
+ ": " value)
+ (unless (bolp)
+ (insert "\n"))
(forward-line -1))
;; The value of this header was empty, so we clear
;; totally and insert the new value.
(delete-region (point) (gnus-point-at-eol))
- (insert value))
+ (insert value)
+ (when (bolp)
+ (delete-char -1)))
;; Add the deletable property to the headers that require it.
(and (memq header message-deletable-headers)
(progn (beginning-of-line) (looking-at "[^:]+: "))
(replace-match " " t t))
(goto-char (point-max)))))
+(defun message-shorten-1 (list cut surplus)
+ ;; Cut SURPLUS elements out of LIST, beginning with CUTth one.
+ (setcdr (nthcdr (- cut 2) list)
+ (nthcdr (+ (- cut 2) surplus 1) list)))
+
(defun message-shorten-references (header references)
- "Limit REFERENCES to be shorter than 988 characters."
- (let ((max 988)
- (cut 4)
+ "Trim REFERENCES to be less than 31 Message-ID long, and fold them.
+If folding is disallowed, also check that the REFERENCES are less
+than 988 characters long, and if they are not, trim them until they are."
+ (let ((maxcount 31)
+ (count 0)
+ (cut 6)
refs)
(with-temp-buffer
(insert references)
(goto-char (point-min))
+ ;; Cons a list of valid references.
(while (re-search-forward "<[^>]+>" nil t)
(push (match-string 0) refs))
- (setq refs (nreverse refs))
- (while (> (length (mapconcat 'identity refs " ")) max)
- (when (< (length refs) (1+ cut))
- (decf cut))
- (setcdr (nthcdr cut refs) (cddr (nthcdr cut refs)))))
- (insert (capitalize (symbol-name header)) ": "
- (mapconcat 'identity refs " ") "\n")))
+ (setq refs (nreverse refs)
+ count (length refs)))
+
+ ;; If the list has more than MAXCOUNT elements, trim it by
+ ;; removing the CUTth element and the required number of
+ ;; elements that follow.
+ (when (> count maxcount)
+ (let ((surplus (- count maxcount)))
+ (message-shorten-1 refs cut surplus)
+ (decf count surplus)))
+
+ ;; If folding is disallowed, make sure the total length (including
+ ;; the spaces between) will be less than MAXSIZE characters.
+ ;;
+ ;; Only disallow folding for News messages. At this point the headers
+ ;; have not been generated, thus we use message-this-is-news directly.
+ (when (and message-this-is-news message-cater-to-broken-inn)
+ (let ((maxsize 988)
+ (totalsize (+ (apply #'+ (mapcar #'length refs))
+ (1- count)))
+ (surplus 0)
+ (ptr (nthcdr (1- cut) refs)))
+ ;; Decide how many elements to cut off...
+ (while (> totalsize maxsize)
+ (decf totalsize (1+ (length (car ptr))))
+ (incf surplus)
+ (setq ptr (cdr ptr)))
+ ;; ...and do it.
+ (when (> surplus 0)
+ (message-shorten-1 refs cut surplus))))
+
+ ;; Finally, collect the references back into a string and insert
+ ;; it into the buffer.
+ (let ((refstring (mapconcat #'identity refs " ")))
+ (if (and message-this-is-news message-cater-to-broken-inn)
+ (insert (capitalize (symbol-name header)) ": "
+ refstring "\n")
+ (message-fill-header header refstring)))))
(defun message-position-point ()
"Move point to where the user probably wants to find it."
(t
(format "*%s message*" type))))
+(defmacro message-pop-to-buffer-1 (buffer)
+ `(if pop-up-frames
+ (let (special-display-buffer-names
+ special-display-regexps
+ same-window-buffer-names
+ same-window-regexps)
+ (pop-to-buffer ,buffer))
+ (pop-to-buffer ,buffer)))
+
(defun message-pop-to-buffer (name)
"Pop to buffer NAME, and warn if it already exists and is modified."
- (let ((pop-up-frames pop-up-frames)
- (special-display-buffer-names special-display-buffer-names)
- (special-display-regexps special-display-regexps)
- (same-window-buffer-names same-window-buffer-names)
- (same-window-regexps same-window-regexps)
- (buffer (get-buffer name))
- (cur (current-buffer)))
- (if (or (and (featurep 'xemacs)
- (not (eq 'tty (device-type))))
- window-system
- (>= emacs-major-version 20))
- (when message-use-multi-frames
- (setq pop-up-frames t
- special-display-buffer-names nil
- special-display-regexps nil
- same-window-buffer-names nil
- same-window-regexps nil))
- (setq pop-up-frames nil))
+ (let ((buffer (get-buffer name))
+ (pop-up-frames (and (or (static-if (featurep 'xemacs)
+ (device-on-window-system-p)
+ window-system)
+ (>= emacs-major-version 20))
+ message-use-multi-frames)))
(if (and buffer
(buffer-name buffer))
(progn
- (set-buffer (pop-to-buffer buffer))
+ (message-pop-to-buffer-1 buffer)
(when (and (buffer-modified-p)
(not (y-or-n-p
"Message already being composed; erase? ")))
(error "Message being composed")))
- (set-buffer (pop-to-buffer name)))
+ (message-pop-to-buffer-1 name))
(erase-buffer)
(message-mode)
(when pop-up-frames
- (make-local-variable 'message-original-frame)
- (setq message-original-frame (selected-frame)))))
+ (set (make-local-variable 'message-original-frame) (selected-frame)))))
(defun message-do-send-housekeeping ()
"Kill old message buffers."
(message-insert-signature)
(save-restriction
(message-narrow-to-headers)
+ (if message-alternative-emails
+ (message-use-alternative-email-as-from))
(run-hooks 'message-header-setup-hook))
(set-buffer-modified-p nil)
(setq buffer-undo-list nil)
message-auto-save-directory))
(setq buffer-auto-save-file-name (make-auto-save-file-name)))
(clear-visited-file-modtime)
- (setq buffer-file-coding-system message-draft-coding-system)))
+ (static-if (boundp 'MULE)
+ (set-file-coding-system message-draft-coding-system)
+ (setq buffer-file-coding-system message-draft-coding-system))))
(defun message-disassociate-draft ()
"Disassociate the message buffer from the drafts directory."
(message-setup `((Newsgroups . ,(or newsgroups ""))
(Subject . ,(or subject ""))))))
-;;;###autoload
-(defun message-reply (&optional to-address wide)
- "Start editing a reply to the article in the current buffer."
- (interactive)
- (let ((cur (current-buffer))
- from subject date to cc
- references message-id follow-to
- (inhibit-point-motion-hooks t)
- mct never-mct mft mrt gnus-warning in-reply-to)
- (save-restriction
- (message-narrow-to-head)
- ;; Allow customizations to have their say.
- (if (not wide)
- ;; This is a regular reply.
- (if (message-functionp message-reply-to-function)
- (setq follow-to (funcall message-reply-to-function)))
- ;; This is a followup.
- (if (message-functionp message-wide-reply-to-function)
- (save-excursion
- (setq follow-to
- (funcall message-wide-reply-to-function)))))
- ;; Find all relevant headers we need.
- (setq from (message-fetch-field "from")
- date (message-fetch-field "date" t)
- subject (or (message-fetch-field "subject") "none")
- references (message-fetch-field "references")
- message-id (message-fetch-field "message-id" t)
- to (message-fetch-field "to")
- cc (message-fetch-field "cc")
- mct (when (and wide message-use-mail-copies-to)
- (message-fetch-field "mail-copies-to"))
- mft (when (and wide message-use-mail-followup-to)
- (message-fetch-field "mail-followup-to"))
- mrt (when message-use-mail-reply-to
- (or (message-fetch-field "mail-reply-to")
- (message-fetch-field "reply-to")))
- gnus-warning (message-fetch-field "gnus-warning"))
- (when (and gnus-warning (string-match "<[^>]+>" gnus-warning))
- (setq message-id (match-string 0 gnus-warning)))
- ;; Get the references from "In-Reply-To" field if there were
- ;; no references and "In-Reply-To" field looks promising.
- (unless references
- (when (and (setq in-reply-to (message-fetch-field "in-reply-to"))
- (string-match "<[^>]+>" in-reply-to))
- (setq references (match-string 0 in-reply-to))))
- ;; Remove any (buggy) Re:'s that are present and make a
- ;; proper one.
- (setq subject (message-make-followup-subject subject))
- (widen))
+(defun message-get-reply-headers (wide &optional to-address)
+ (let (follow-to mct never-mct from to cc reply-to mrt mft)
+ ;; Find all relevant headers we need.
+ (setq from (message-fetch-field "from")
+ to (message-fetch-field "to")
+ cc (message-fetch-field "cc")
+ mct (when message-use-mail-copies-to
+ (message-fetch-field "mail-copies-to"))
+ reply-to (message-fetch-field "reply-to")
+ mrt (when message-use-mail-reply-to
+ (message-fetch-field "mail-reply-to"))
+ mft (when (and (not (or to-address mrt reply-to))
+ message-use-mail-followup-to)
+ (message-fetch-field "mail-followup-to")))
;; Handle special values of Mail-Copies-To.
(when mct
`Mail-Copies-To: always'
sends a copy of your response to the author.")))
- (setq mct (or mrt from)))
+ (setq mct (or mrt reply-to from)))
((and (eq message-use-mail-copies-to 'ask)
(not
(message-y-or-n-p
sends a copy of your response to " (if (string-match "," mct)
"the specified addresses"
"that address") ".")))
- (setq mct nil))
- ))
+ (setq mct nil))))
- (unless follow-to
- (cond
- (to-address (setq follow-to (list (cons 'To to-address))))
- ((not wide) (setq follow-to (list (cons 'To (or mrt from)))))
- ;; Handle Mail-Followup-To.
- ((and mft
- (or (not (eq message-use-mail-followup-to 'ask))
- (message-y-or-n-p
- (concat "Obey Mail-Followup-To: " mft "? ") t "\
+ ;; Handle Mail-Followup-To.
+ (when (and mft
+ (eq message-use-mail-followup-to 'ask)
+ (not (message-y-or-n-p
+ (concat "Obey Mail-Followup-To: " mft "? ") t "\
You should normally obey the Mail-Followup-To: header.
`Mail-Followup-To: " mft "'
A typical situation where Mail-Followup-To is used is when the author thinks
that further discussion should take place only in "
- (if (string-match "," mft)
- "the specified mailing lists"
- "that mailing list") ".")))
- (setq follow-to (list (cons 'To mft)))
- (when mct
- (push (cons 'Cc mct) follow-to)))
- (t
- (let (ccalist)
- (save-excursion
- (message-set-work-buffer)
+ (if (string-match "," mft)
+ "the specified mailing lists"
+ "that mailing list") ".")))
+ (setq mft nil))
+
+ (if (or (not wide)
+ to-address)
+ (progn
+ (setq follow-to (list (cons 'To
+ (or to-address mrt reply-to mft from))))
+ (when (and wide mct)
+ (push (cons 'Cc mct) follow-to)))
+ (let (ccalist)
+ (save-excursion
+ (message-set-work-buffer)
+ (if (and mft
+ message-use-followup-to
+ (or (not (eq message-use-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
+
+" mft "
+
+which directs your response to " (if (string-match "," mft)
+ "the specified addresses"
+ "that address only") ".
+
+If a message is posted to several mailing lists, Mail-Followup-To is
+often used to direct the following discussion to one list only,
+because discussions that are spread over several lists tend to be
+fragmented and very difficult to follow.
+
+Also, some source/announcement lists are not indented for discussion;
+responses here are directed to other addresses.")))
+ (insert mft)
(unless never-mct
- (insert (or mrt from "")))
+ (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'.
+ (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 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)))))))
-
- (message-pop-to-buffer (message-buffer-name
- (if wide "wide reply" "reply") from
- (if wide to-address nil)))
+ (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)))))
+ follow-to))
+
+;;;###autoload
+(defun message-reply (&optional to-address wide)
+ "Start editing a reply to the article in the current buffer."
+ (interactive)
+ (require 'gnus-sum) ; for gnus-list-identifiers
+ (let ((cur (current-buffer))
+ from subject date
+ references message-id follow-to
+ (inhibit-point-motion-hooks t)
+ (message-this-is-mail t)
+ gnus-warning in-reply-to)
+ (save-restriction
+ (message-narrow-to-head)
+ ;; Allow customizations to have their say.
+ (if (not wide)
+ ;; This is a regular reply.
+ (if (message-functionp message-reply-to-function)
+ (setq follow-to (funcall message-reply-to-function)))
+ ;; This is a followup.
+ (if (message-functionp message-wide-reply-to-function)
+ (save-excursion
+ (setq follow-to
+ (funcall message-wide-reply-to-function)))))
+ (setq message-id (message-fetch-field "message-id" t)
+ references (message-fetch-field "references")
+ date (message-fetch-field "date")
+ from (message-fetch-field "from")
+ subject (or (message-fetch-field "subject") "none"))
+ (if gnus-list-identifiers
+ (setq subject (message-strip-list-identifiers subject)))
+ (setq subject (message-make-followup-subject subject))
+
+ (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
+ (string-match "<[^>]+>" gnus-warning))
+ (setq message-id (match-string 0 gnus-warning)))
+
+ (unless follow-to
+ (setq follow-to (message-get-reply-headers wide to-address)))
+
+ ;; Get the references from "In-Reply-To" field if there were
+ ;; no references and "In-Reply-To" field looks promising.
+ (unless references
+ (when (and (setq in-reply-to (message-fetch-field "in-reply-to"))
+ (string-match "<[^>]+>" in-reply-to))
+ (setq references (match-string 0 in-reply-to)))))
+
+ (message-pop-to-buffer
+ (message-buffer-name
+ (if wide "wide reply" "reply") from
+ (if wide to-address nil)))
(setq message-reply-headers
(make-full-mail-header-from-decoded-header
,@follow-to
,@(if (or references message-id)
`((References . ,(concat (or references "") (and references " ")
- (or message-id ""))))))
+ (or message-id ""))))
+ nil))
cur)))
;;;###autoload
"Follow up to the message in the current buffer.
If TO-NEWSGROUPS, use that as the new Newsgroups line."
(interactive)
+ (require 'gnus-sum) ; for gnus-list-identifiers
(let ((cur (current-buffer))
- from subject date mct
+ from subject date reply-to mrt mct mft
references message-id follow-to
(inhibit-point-motion-hooks t)
(message-this-is-news t)
- followup-to distribution newsgroups gnus-warning posted-to mft mrt)
+ followup-to distribution newsgroups gnus-warning posted-to)
(save-restriction
(message-narrow-to-head)
(when (message-functionp message-followup-to-function)
(setq follow-to
(funcall message-followup-to-function)))
(setq from (message-fetch-field "from")
- date (message-fetch-field "date" t)
+ date (message-fetch-field "date")
subject (or (message-fetch-field "subject") "none")
references (message-fetch-field "references")
message-id (message-fetch-field "message-id" t)
- followup-to (when message-use-followup-to
- (message-fetch-field "followup-to"))
- distribution (message-fetch-field "distribution")
+ followup-to (message-fetch-field "followup-to")
newsgroups (message-fetch-field "newsgroups")
posted-to (message-fetch-field "posted-to")
+ reply-to (message-fetch-field "reply-to")
+ mrt (when message-use-mail-reply-to
+ (message-fetch-field "mail-reply-to"))
+ distribution (message-fetch-field "distribution")
mct (when message-use-mail-copies-to
(message-fetch-field "mail-copies-to"))
mft (when message-use-mail-followup-to
- (message-fetch-field "mail-followup-to"))
- mrt (when message-use-mail-reply-to
- (or (message-fetch-field "mail-reply-to")
- (message-fetch-field "reply-to")))
- gnus-warning (message-fetch-field "gnus-warning"))
- (when (and gnus-warning (string-match "<[^>]+>" gnus-warning))
+ (message-fetch-field "mail-followup-to")))
+ (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
+ (string-match "<[^>]+>" gnus-warning))
(setq message-id (match-string 0 gnus-warning)))
;; Remove bogus distribution.
(when (and (stringp distribution)
(let ((case-fold-search t))
(string-match "world" distribution)))
(setq distribution nil))
- ;; Remove any (buggy) Re:'s that are present and make a
- ;; proper one.
+ (if gnus-list-identifiers
+ (setq subject (message-strip-list-identifiers subject)))
(setq subject (message-make-followup-subject subject))
(widen))
`Mail-Copies-To: always'
sends a copy of your response to the author.")))
- (setq mct (or mrt from)))
+ (setq mct (or mrt reply-to from)))
((and (eq message-use-mail-copies-to 'ask)
(not
(message-y-or-n-p
(followup-to
(cond
((equal (downcase followup-to) "poster")
- (if (or (eq message-use-followup-to 'use)
+ (if (or (and followup-to (eq message-use-followup-to 'use))
(message-y-or-n-p "Obey Followup-To: poster? " t "\
You should normally obey the Followup-To: header.
does not read the newsgroup, so he wouldn't see any replies sent to it."))
(setq message-this-is-news nil
distribution nil
- follow-to (list (cons 'To (or mrt from ""))))
+ follow-to (list (cons 'To (or mrt reply-to from ""))))
(setq follow-to (list (cons 'Newsgroups newsgroups)))))
(t
(if (or (equal followup-to newsgroups)
- (not (eq message-use-followup-to 'ask))
+ (not (and followup-to (eq message-use-followup-to 'ask)))
(message-y-or-n-p
(concat "Obey Followup-To: " followup-to "? ") t "\
You should normally obey the Followup-To: header.
(message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
- (setq message-reply-headers
- (make-full-mail-header-from-decoded-header
- 0 subject from date message-id references 0 0 ""))
-
(message-setup
`((Subject . ,subject)
,@follow-to
,@(if (or references message-id)
`((References . ,(concat (or references "") (and references " ")
(or message-id ""))))))
- cur)))
+ cur)
+
+ (setq message-reply-headers
+ (make-full-mail-header-from-decoded-header
+ 0 subject from date message-id references 0 0 ""))))
;;;###autoload
-(defun message-cancel-news ()
- "Cancel an article you posted."
- (interactive)
+(defun message-cancel-news (&optional arg)
+ "Cancel an article you posted.
+If ARG, allow editing of the cancellation message."
+ (interactive "P")
(unless (message-news-p)
(error "This is not a news article; canceling is impossible"))
(when (yes-or-no-p "Do you really want to cancel this article? ")
(let (from newsgroups message-id distribution buf sender)
(save-excursion
- ;; Get header info. from original article.
+ ;; Get header info from original article.
(save-restriction
(message-narrow-to-head)
(setq from (message-fetch-field "from")
(message-make-from))))))
(error "This article is not yours"))
;; Make control message.
- (setq buf (set-buffer (get-buffer-create " *message cancel*")))
+ (if arg
+ (message-news)
+ (setq buf (set-buffer (get-buffer-create " *message cancel*"))))
(erase-buffer)
(insert "Newsgroups: " newsgroups "\n"
- "From: " (message-make-from) "\n"
+ "From: " from "\n"
"Subject: cmsg cancel " message-id "\n"
"Control: cancel " message-id "\n"
(if distribution
message-cancel-message)
(run-hooks 'message-cancel-hook)
(message "Canceling your article...")
- (if (let ((message-syntax-checks
- 'dont-check-for-anything-just-trust-me)
- (message-encoding-buffer (current-buffer))
- (message-edit-buffer (current-buffer)))
- (message-send-news))
- (message "Canceling your article...done"))
- (kill-buffer buf)))))
+ (unless arg
+ (if (let ((message-syntax-checks
+ 'dont-check-for-anything-just-trust-me)
+ (message-encoding-buffer (current-buffer))
+ (message-edit-buffer (current-buffer)))
+ (message-send-news))
+ (message "Canceling your article...done"))
+ (kill-buffer buf))))))
(defun message-supersede-setup-for-mime-edit ()
(set (make-local-variable 'message-setup-hook) nil)
(cond ((save-window-excursion
(if (not (eq system-type 'vax-vms))
(with-output-to-temp-buffer "*Directory*"
+ (with-current-buffer standard-output
+ (fundamental-mode)) ; for Emacs 20.4+
(buffer-disable-undo standard-output)
(let ((default-directory "/"))
(call-process
"Return a Subject header suitable for the message in the current buffer."
(save-excursion
(save-restriction
- (current-buffer)
(message-narrow-to-head)
(let ((funcs message-make-forward-subject-function)
(subject (message-fetch-field "Subject")))
(message-mail nil subject))
;; Put point where we want it before inserting the forwarded
;; message.
- (if message-signature-before-forwarded-message
- (goto-char (point-max))
- (message-goto-body))
+ (if message-forward-before-signature
+ (message-goto-body)
+ (goto-char (point-max)))
;; Make sure we're at the start of the line.
- (unless (eolp)
+ (unless (bolp)
(insert "\n"))
;; Narrow to the area we are to insert.
(narrow-to-region (point) (point))
;;;###autoload
(defun message-resend (address)
"Resend the current article to ADDRESS."
- (interactive "sResend message to: ")
+ (interactive
+ (list (message-read-from-minibuffer "Resend message to: ")))
(message "Resending message to %s..." address)
(save-excursion
(let ((cur (current-buffer))
;;;###autoload
(defun message-bounce ()
"Re-mail the current message.
-This only makes sense if the current message is a bounce message than
+This only makes sense if the current message is a bounce message that
contains some mail you have written which has been bounced back to
you."
(interactive)
(defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
;; Support for toolbar
-(when (string-match "XEmacs\\|Lucid" emacs-version)
+(when (featurep 'xemacs)
(require 'messagexmas))
;;; Group name completion.
(save-excursion
(with-output-to-temp-buffer " *MESSAGE information message*"
(set-buffer " *MESSAGE information message*")
+ (fundamental-mode) ; for Emacs 20.4+
(mapcar 'princ text)
(goto-char (point-min))))
(funcall ask question))
(let ((oldbuf (current-buffer)))
(save-excursion
(set-buffer (generate-new-buffer name))
- (message-clone-locals oldbuf)
+ (message-clone-locals oldbuf varstr)
(current-buffer))))
-(defun message-clone-locals (buffer)
+(defun message-clone-locals (buffer &optional varstr)
"Clone the local variables from BUFFER to the current buffer."
(let ((locals (save-excursion
(set-buffer buffer)
(lambda (local)
(when (and (consp local)
(car local)
- (string-match regexp (symbol-name (car local))))
+ (string-match regexp (symbol-name (car local)))
+ (or (null varstr)
+ (string-match varstr (symbol-name (car local)))))
(ignore-errors
(set (make-local-variable (car local))
(cdr local)))))
;;; Miscellaneous functions
;; stolen (and renamed) from nnheader.el
-(defun message-replace-chars-in-string (string from to)
- "Replace characters in STRING from FROM to TO."
- (let ((string (substring string 0)) ;Copy string.
- (len (length string))
- (idx 0))
- ;; Replace all occurrences of FROM with TO.
- (while (< idx len)
- (when (= (aref string idx) from)
- (aset string idx to))
- (setq idx (1+ idx)))
- string))
+(static-if (fboundp 'subst-char-in-string)
+ (defsubst message-replace-chars-in-string (string from to)
+ (subst-char-in-string from to string))
+ (defun message-replace-chars-in-string (string from to)
+ "Replace characters in STRING from FROM to TO."
+ (let ((string (substring string 0)) ;Copy string.
+ (len (length string))
+ (idx 0))
+ ;; Replace all occurrences of FROM with TO.
+ (while (< idx len)
+ (when (= (aref string idx) from)
+ (aset string idx to))
+ (setq idx (1+ idx)))
+ string)))
;;;
;;; MIME functions
(defun message-encode-message-body ()
(unless message-inhibit-body-encoding
(let ((mail-parse-charset (or mail-parse-charset
- message-default-charset
- message-posting-charset))
+ message-default-charset))
(case-fold-search t)
lines content-type-p)
(message-goto-body)
(delete-char 1)
(search-forward "\n\n")
(setq lines (buffer-substring (point-min) (1- (point))))
- (delete-region (point-min) (point))))))
+ (delete-region (point-min) (point))))))
(save-restriction
(message-narrow-to-headers-or-head)
(message-remove-header "Mime-Version")
(forward-line 1)
(insert "Content-Type: text/plain; charset=us-ascii\n")))))
-(defvar message-save-buffer " *encoding")
+(defun message-read-from-minibuffer (prompt)
+ "Read from the minibuffer while providing abbrev expansion."
+ (if (fboundp 'mail-abbrevs-setup)
+ (let ((mail-abbrev-mode-regexp "")
+ (minibuffer-setup-hook 'mail-abbrevs-setup))
+ (read-from-minibuffer prompt))
+ (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook))
+ (read-string prompt))))
+
+(defun message-use-alternative-email-as-from ()
+ (require 'mail-utils)
+ (let* ((fields '("To" "Cc"))
+ (emails
+ (split-string
+ (mail-strip-quoted-names
+ (mapconcat 'message-fetch-reply-field fields ","))
+ "[ \f\t\n\r\v,]+"))
+ email)
+ (while emails
+ (if (string-match message-alternative-emails (car emails))
+ (setq email (car emails)
+ emails nil))
+ (pop emails))
+ (unless (or (not email) (equal email user-mail-address))
+ (goto-char (point-max))
+ (insert "From: " email "\n"))))
+
+(defun message-options-get (symbol)
+ (cdr (assq symbol message-options)))
+
+(defun message-options-set (symbol value)
+ (let ((the-cons (assq symbol message-options)))
+ (if the-cons
+ (if value
+ (setcdr the-cons value)
+ (setq message-options (delq the-cons message-options)))
+ (and value
+ (push (cons symbol value) message-options))))
+ value)
+
+(defun message-options-set-recipient ()
+ (save-restriction
+ (message-narrow-to-headers-or-head)
+ (message-options-set 'message-sender
+ (mail-strip-quoted-names
+ (message-fetch-field "from")))
+ (message-options-set 'message-recipients
+ (mail-strip-quoted-names
+ (message-fetch-field "to")))))
+
(defun message-save-drafts ()
+ "Postponing the message."
(interactive)
- (if (not (get-buffer message-save-buffer))
- (get-buffer-create message-save-buffer))
- (let ((filename buffer-file-name)
- (buffer (current-buffer)))
- (set-buffer message-save-buffer)
- (erase-buffer)
- (insert-buffer buffer)
- (mime-edit-translate-buffer)
- (write-region (point-min) (point-max) filename)
- (set-buffer buffer)
- (set-buffer-modified-p nil)))
+ (message "Saving %s..." buffer-file-name)
+ (let ((reply-headers message-reply-headers)
+ (msg (buffer-substring-no-properties (point-min) (point-max))))
+ (with-temp-file buffer-file-name
+ (insert msg)
+ (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)
+;; Local Variables:
+;; coding: iso-8859-1
+;; End:
+
;;; message.el ends here
projects / elisp / gnus.git- / blobdiff