;;; message.el --- composing mail and news messages
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: mail, news
+;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
+;; Keiichi Suzuki <kei-suzu@mail.wbs.ne.jp>
+;; Keywords: mail, news, MIME
;; This file is part of GNU Emacs.
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile
+ (require 'cl)
+ (require 'smtp)
+ )
+
(require 'mailheader)
(require 'nnheader)
+(require 'timezone)
(require 'easymenu)
+(require 'custom)
(if (string-match "XEmacs\\|Lucid" emacs-version)
(require 'mail-abbrevs)
(require 'mailabbrev))
-(require 'mail-parse)
-(require 'mm-bodies)
-(require 'mm-encode)
-(require 'mml)
+(require 'mime-edit)
(defgroup message '((user-mail-address custom-variable)
(user-full-name custom-variable))
:group 'message
:group 'faces)
+(defgroup message-frames nil
+ "Message frames"
+ :group 'message)
+
(defcustom message-directory "~/Mail/"
"*Directory from which all other mail file variables are derived."
:group 'message-various
(function :tag "Other"))
:group 'message-sending)
+(defcustom message-encode-function 'message-maybe-encode
+ "*A function called to encode messages."
+ :group 'message-sending
+ :type 'function)
+
+(defcustom message-8bit-encoding-list '(8bit binary)
+ "*8bit encoding type in Content-Transfer-Encoding field."
+ :group 'message-sending
+ :type '(repeat (symbol :tag "Type")))
+
(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-interface
:type 'regexp)
+(defcustom message-bounce-setup-function 'message-bounce-setup-for-mime-edit
+ "Function to setup a re-sending bounced message."
+ :group 'message-sending
+ :type 'function)
+
;;;###autoload
(defcustom message-from-style 'default
"*Specifies how \"From\" headers look.
: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.
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
-newsgroups."
+shorten-followup-to existing-newsgroups buffer-file-name unchanged."
:group 'message-news)
(defcustom message-required-news-headers
:group 'message-headers
:type 'regexp)
-(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:"
+(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^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."
:group 'message-interface
:type 'regexp)
+(defcustom message-supersede-setup-function
+ 'message-supersede-setup-for-mime-edit
+ "Function to setup a supersede message."
+ :group 'message-sending
+ :type 'function)
+
(defcustom message-subject-re-regexp "^[ \t]*\\([Rr][Ee]:[ \t]*\\)*[ \t]*"
"*Regexp matching \"Re: \" in the subject line."
:group 'message-various
:type 'regexp
:group 'message-various)
-(defcustom message-elide-ellipsis "\n[...]\n\n"
+(defcustom message-elide-elipsis "\n[...]\n\n"
"*The string which is inserted for elided text."
:type 'string
:group 'message-various)
:group 'message-mail
:type 'boolean)
-(defcustom message-generate-new-buffers 'unique
+(defcustom message-generate-new-buffers t
"*Non-nil means that a new message buffer will be created whenever `message-setup' is called.
If this is a function, call that function with three parameters: The type,
the to address and the group name. (Any of these may be nil.) The function
should return the new buffer name."
:group 'message-buffers
:type '(choice (const :tag "off" nil)
- (const :tag "unique" unique)
- (const :tag "unsent" unsent)
+ (const :tag "on" t)
(function fun)))
(defcustom message-kill-buffer-on-exit nil
:group 'message-buffers
:type 'boolean)
+(defcustom message-kill-buffer-query-function 'yes-or-no-p
+ "*A function called to query the user whether to kill buffer anyway or not.
+If it is t, the buffer will be killed peremptorily."
+ :type '(radio (function-item yes-or-no-p)
+ (function-item y-or-n-p)
+ (function-item nnheader-Y-or-n-p)
+ (function :tag "Other" t))
+ :group 'message-buffers)
+
(defvar gnus-local-organization)
(defcustom message-user-organization
(or (and (boundp 'gnus-local-organization)
:type 'file
:group 'message-headers)
-(defcustom message-make-forward-subject-function
+(defcustom message-forward-start-separator
+ (concat (mime-make-tag "message" "rfc822") "\n")
+ "*Delimiter inserted before forwarded messages."
+ :group 'message-forwarding
+ :type 'string)
+
+(defcustom message-forward-end-separator
+ (concat (mime-make-tag "text" "plain") "\n")
+ "*Delimiter inserted after forwarded messages."
+ :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:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-Transfer-Encoding:\\|^Content-Type:\\|^MIME-Version:"
+ "*Regexp matching headers to be included in forwarded messages."
+ :group 'message-forwarding
+ :type 'regexp)
+
+(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)))
-
-(defcustom message-forward-as-mime t
- "*If non-nil, forward messages as an inline/rfc822 MIME section. Otherwise, directly inline the old message in the forwarded message."
- :group 'message-forwarding
- :type 'boolean)
-
-(defcustom message-forward-before-signature t
- "*If non-nil, put forwarded message before signature, else after."
- :group 'message-forwarding
- :type 'boolean)
+ :group 'message-forwarding
+ :type '(radio (function-item message-forward-subject-author-subject)
+ (function-item message-forward-subject-fwd)))
(defcustom message-wash-forwarded-subjects nil
"*If non-nil, try to remove as much old cruft as possible from the subject of messages before generating the new subject of a forward."
:group 'message-forwarding
:type 'boolean)
-(defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:"
+(defcustom message-ignored-resent-headers "^Return-receipt"
"*All headers that match this regexp will be deleted when resending a message."
:group 'message-interface
:type 'regexp)
-(defcustom message-forward-ignored-headers "Content-Transfer-Encoding"
- "*All headers that match this regexp will be deleted when forwarding a message."
- :group 'message-forwarding
- :type '(choice (const :tag "None" nil)
- 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.\n"
+(defcustom message-cancel-message "I am canceling my own article."
"Message to be inserted in the cancel message."
:group 'message-interface
:type 'string)
The headers should be delimited by a line whose contents match the
variable `mail-header-separator'.
-Valid values include `message-send-mail-with-sendmail' (the default),
+Legal values include `message-send-mail-with-sendmail' (the default),
`message-send-mail-with-mh', `message-send-mail-with-qmail' and
-`smtpmail-send-it'."
+`message-send-mail-with-smtp'."
: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 smtpmail-send-it)
+ (function-item message-send-mail-with-smtp)
(function :tag "Other"))
:group 'message-sending
:group 'message-mail)
-(defcustom message-send-news-function 'message-send-news
+;; 1997-09-29 by MORIOKA Tomohiko
+(defcustom message-send-news-function 'message-send-news-with-gnus
"Function to call to send the current buffer as news.
The headers should be delimited by a line whose contents match the
variable `mail-header-separator'."
(const use)
(const 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.
-Doing so would be even more evil than leaving it out."
+ "*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."
: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-headers
:type 'boolean)
-(defcustom message-setup-hook nil
+(defcustom message-setup-hook
+ '(message-maybe-setup-default-charset turn-on-mime-edit)
"Normal hook, run each time a new outgoing message is initialized.
The function `message-setup' runs this hook."
:group 'message-various
:type 'hook)
-(defcustom message-cancel-hook nil
- "Hook run when cancelling articles."
- :group 'message-various
- :type 'hook)
-
(defcustom message-signature-setup-hook nil
"Normal hook, run each time a new outgoing message is initialized.
It is run after the headers have been inserted and before
:group 'message-various
:type 'hook)
+(defcustom message-bounce-setup-hook nil
+ "Normal hook, run each time a a re-sending bounced message is initialized.
+The function `message-bounce' runs this hook."
+ :group 'message-various
+ :type 'hook)
+
+(defcustom message-supersede-setup-hook nil
+ "Normal hook, run each time a supersede message is initialized.
+The function `message-supersede' runs this hook."
+ :group 'message-various
+ :type 'hook)
+
(defcustom message-mode-hook nil
"Hook run in message mode buffers."
:group 'message-various
:type 'hook)
-(defcustom message-header-hook nil
+(defcustom message-header-hook '(eword-encode-header)
"Hook run in a message mode buffer narrowed to the headers."
:group 'message-various
:type 'hook)
;;;###autoload
(defcustom message-yank-prefix "> "
- "*Prefix inserted on the lines of yanked messages."
+ "*Prefix inserted on the lines of yanked messages.
+nil means use indentation."
:type 'string
:group 'message-insertion)
`message-cite-original-without-signature'.
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 sc-cite-original)
(function :tag "Other"))
:group 'message-insertion)
"A list of actions to be performed before killing a message buffer.")
(defvar message-postpone-actions nil
"A list of actions to be performed after postponing a message.")
+(defvar message-original-frame nil)
+(defvar message-parameter-alist nil)
+(defvar message-startup-parameter-alist nil)
(define-widget 'message-header-lines 'text
"All header lines must be LFD terminated."
: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)
:group 'message-sending
:type 'sexp)
+;;; XXX: This symbol is overloaded! See below.
+(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.
;;;###autoload
-(ignore-errors
- (define-mail-user-agent 'message-user-agent
- 'message-mail 'message-send-and-exit
- 'message-kill-buffer 'message-send-hook))
+(condition-case nil
+ (define-mail-user-agent 'message-user-agent
+ 'message-mail 'message-send-and-exit
+ 'message-kill-buffer 'message-send-hook)
+ (error nil))
(defvar message-mh-deletable-headers '(Message-ID Date Lines Sender)
"If non-nil, delete the deletable headers before feeding to mh.")
:group 'message-buffers
:type 'directory)
-(defcustom message-buffer-naming-style 'unique
- "*The way new message buffers are named.
-Valid valued are `unique' and `unsent'."
- :group 'message-buffers
- :type '(choice (const :tag "unique" unique)
- (const :tag "unsent" unsent)))
-
-(defcustom message-default-charset nil
- "Default charset used in non-MULE XEmacsen."
- :group 'message
- :type 'symbol)
-
-(defcustom message-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.
(defvar message-mode-syntax-table
(let ((table (copy-syntax-table text-mode-syntax-table)))
(modify-syntax-entry ?% ". " table)
- (modify-syntax-entry ?> ". " table)
- (modify-syntax-entry ?< ". " table)
table)
"Syntax table used while in Message mode.")
"Face used for displaying cited text names."
:group 'message-faces)
-(defface message-mml-face
- '((((class color)
- (background dark))
- (:foreground "ForestGreen"))
- (((class color)
- (background light))
- (:foreground "ForestGreen"))
- (t
- (:bold t)))
- "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_.@-"))
(,(concat "^[ \t]*"
"\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
"[:>|}].*")
- (0 'message-cited-text-face))
- ("<#/?\\(multipart\\|part\\|external\\).*>"
- (0 'message-mml-face))))
+ (0 'message-cited-text-face))))
"Additional expressions to highlight in Message mode.")
;; XEmacs does it like this. For Emacs, we have to set the
:group 'message-various
:type 'hook)
-(defvar message-send-coding-system 'binary
- "Coding system to encode outgoing mail.")
+(defcustom message-use-multi-frames nil
+ "Make new frame when sending messages."
+ :group 'message-frames
+ :type 'boolean)
-(defvar message-draft-coding-system
- mm-auto-save-coding-system
- "Coding system to compose mail.")
+(defcustom message-delete-frame-on-exit nil
+ "Delete frame after sending messages."
+ :group 'message-frames
+ :type '(choice (const :tag "off" nil)
+ (const :tag "always" t)
+ (const :tag "ask" ask)))
;;; Internal variables.
(defvar message-this-is-news nil)
(defvar message-this-is-mail nil)
(defvar message-draft-article nil)
-(defvar message-mime-part nil)
-(defvar message-posting-charset nil)
;; Byte-compiler warning
(defvar gnus-active-hashtb)
"\\([^\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.")
(Lines)
(Expires)
(Message-ID)
- (References . message-shorten-references)
+ (References . message-fill-references)
(User-Agent))
"Alist used for formatting headers.")
(autoload 'gnus-point-at-eol "gnus-util")
(autoload 'gnus-point-at-bol "gnus-util")
(autoload 'gnus-output-to-mail "gnus-util")
+ (autoload 'gnus-output-to-rmail "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")
(autoload 'gnus-request-post "gnus-int")
+ (autoload 'gnus-copy-article-buffer "gnus-msg")
(autoload 'gnus-alive-p "gnus-util")
(autoload 'rmail-output "rmail"))
;;;
;;; Utility functions.
;;;
+(defun message-eval-parameter (parameter)
+ (condition-case ()
+ (if (symbolp parameter)
+ (if (functionp parameter)
+ (funcall parameter)
+ (eval parameter))
+ parameter)
+ (error nil)))
+
+(defsubst message-get-parameter (key &optional alist)
+ (unless alist
+ (setq alist message-parameter-alist))
+ (cdr (assq key alist)))
+
+(defmacro message-get-parameter-with-eval (key &optional alist)
+ `(message-eval-parameter (message-get-parameter ,key ,alist)))
(defmacro message-y-or-n-p (question show &rest text)
"Ask QUESTION, displaying the rest of the arguments in a temp. buffer if SHOW"
(not paren))))
(push (buffer-substring beg (point)) elems)
(setq beg (match-end 0)))
- ((eq (char-after) ?\")
+ ((= (following-char) ?\")
(setq quoted (not quoted)))
- ((and (eq (char-after) ?\()
+ ((and (= (following-char) ?\()
(not quoted))
(setq paren t))
- ((and (eq (char-after) ?\))
+ ((and (= (following-char) ?\))
(not quoted))
(setq paren nil))))
(nreverse elems)))))
(when (and (file-exists-p file)
(file-readable-p file)
(file-regular-p file))
- (with-temp-buffer
+ (nnheader-temp-write nil
(nnheader-insert-file-contents file)
(goto-char (point-min))
(looking-at message-unix-mail-delimiter))))
(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.
- (format "%s" value))))
-
-(defun message-narrow-to-field ()
- "Narrow the buffer to the header on the current line."
- (beginning-of-line)
- (narrow-to-region
- (point)
- (progn
- (forward-line 1)
- (if (re-search-forward "^[^ \n\t]" nil t)
- (progn
- (beginning-of-line)
- (point))
- (point-max))))
- (goto-char (point-min)))
+ (nnheader-replace-chars-in-string value ?\n ? ))))
(defun message-add-header (&rest headers)
"Add the HEADERS to the message header, skipping those already present."
(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."
- (when (and message-reply-buffer
- (buffer-name message-reply-buffer))
- (save-excursion
- (set-buffer message-reply-buffer)
- (message-fetch-field header))))
+ (let ((buffer (message-eval-parameter message-reply-buffer)))
+ (when (and buffer
+ (buffer-name buffer))
+ (save-excursion
+ (set-buffer buffer)
+ (message-fetch-field header)))))
(defun message-set-work-buffer ()
(if (get-buffer " *message work*")
(erase-buffer))
(set-buffer (get-buffer-create " *message work*"))
(kill-all-local-variables)
- (mm-enable-multibyte)))
+ (buffer-disable-undo (current-buffer))))
(defun message-functionp (form)
"Return non-nil if FORM is funcallable."
(forward-line 1)
(if (re-search-forward "^[^ \t]" nil t)
(goto-char (match-beginning 0))
- (goto-char (point-max)))))
+ (point-max))))
number))
-(defun message-remove-first-header (header)
- "Remove the first instance of HEADER if there is more than one."
- (let ((count 0)
- (regexp (concat "^" (regexp-quote header) ":")))
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward regexp nil t)
- (incf count)))
- (while (> count 1)
- (message-remove-header header nil t)
- (decf count))))
-
(defun message-narrow-to-headers ()
"Narrow the buffer to the head of the message."
(widen)
(goto-char (point-min)))
(defun message-narrow-to-head ()
- "Narrow the buffer to the head of the message.
-Point is left at the beginning of the narrowed-to region."
+ "Narrow the buffer to the head of the message."
(widen)
(narrow-to-region
(goto-char (point-min))
(point-max)))
(goto-char (point-min)))
-(defun message-narrow-to-headers-or-head ()
- "Narrow the buffer to the head of the message."
- (widen)
- (narrow-to-region
- (goto-char (point-min))
- (cond
- ((re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
- (match-beginning 0))
- ((search-forward "\n\n" nil t)
- (1- (point)))
- (t
- (point-max))))
- (goto-char (point-min)))
-
(defun message-news-p ()
"Say whether the current buffer contains a news message."
(and (not message-this-is-mail)
(defun message-sort-headers-1 ()
"Sort the buffer as headers using `message-rank' text props."
(goto-char (point-min))
- (require 'sort)
(sort-subr
nil 'message-next-header
(lambda ()
(- max rank)
(1+ max)))))
(message-sort-headers-1))))
-
\f
;;;
(defvar message-mode-map nil)
(unless message-mode-map
- (setq message-mode-map (make-keymap))
- (set-keymap-parent message-mode-map text-mode-map)
+ (setq message-mode-map (copy-keymap text-mode-map))
(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-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)
(define-key message-mode-map "\C-c\C-r" 'message-caesar-buffer-body)
(define-key message-mode-map "\C-c\C-o" 'message-sort-headers)
(define-key message-mode-map "\C-c\M-r" 'message-rename-buffer)
(define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature)
(define-key message-mode-map "\M-\r" 'message-newline-and-reformat)
- (define-key message-mode-map "\C-c\C-a" 'mml-attach-file)
+ (define-key message-mode-map "\t" 'message-tab)
- (define-key message-mode-map "\t" 'message-tab))
+ (define-key message-mode-map "\C-x\C-s" 'message-save-drafts)
+ (define-key message-mode-map "\C-xk" 'message-kill-buffer))
(easy-menu-define
message-mode-menu message-mode-map "Message Menu."
["Newline and Reformat" message-newline-and-reformat t]
["Rename buffer" message-rename-buffer t]
["Spellcheck" ispell-message t]
- ["Attach file as MIME" mml-attach-file t]
"----"
["Send Message" message-send-and-exit t]
["Abort Message" message-dont-send t]
"Major mode for editing mail and news to be sent.
Like Text Mode but with these additional commands:
C-c C-s message-send (send the message) C-c C-c message-send-and-exit
-C-c C-d Pospone sending the message C-c C-k Kill the message
C-c C-f move to a header field (and create it if there isn't):
C-c C-f C-t move to To C-c C-f C-s move to Subject
C-c C-f C-c move to Cc C-c C-f C-b move to Bcc
C-c C-y message-yank-original (insert current message, if any).
C-c C-q message-fill-yanked-message (fill what was yanked).
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-a mml-attach-file (attach a file as MIME).
-M-RET message-newline-and-reformat (break the line and reformat)."
+C-c C-r message-caesar-buffer-body (rot13 the message body)."
(interactive)
(kill-all-local-variables)
- (set (make-local-variable 'message-reply-buffer) nil)
- (make-local-variable 'message-send-actions)
- (make-local-variable 'message-exit-actions)
+ (make-local-variable 'message-reply-buffer)
+ (setq message-reply-buffer nil)
+ (make-local-variable 'message-send-actions)
+ (make-local-variable 'message-exit-actions)
(make-local-variable 'message-kill-actions)
(make-local-variable 'message-postpone-actions)
(make-local-variable 'message-draft-article)
(setq paragraph-separate paragraph-start)
(make-local-variable 'message-reply-headers)
(setq message-reply-headers nil)
- (make-local-variable 'message-newsreader)
- (make-local-variable 'message-mailer)
+ (make-local-variable 'message-user-agent)
(make-local-variable 'message-post-method)
- (set (make-local-variable 'message-sent-message-via) nil)
- (set (make-local-variable 'message-checksum) nil)
- (set (make-local-variable 'message-mime-part) 0)
+ (make-local-variable 'message-sent-message-via)
+ (setq message-sent-message-via nil)
+ (make-local-variable 'message-checksum)
+ (setq message-checksum nil)
+ (make-local-variable 'message-parameter-alist)
+ (setq message-parameter-alist
+ (copy-sequence message-startup-parameter-alist))
;;(when (fboundp 'mail-hist-define-keys)
;; (mail-hist-define-keys))
(when (string-match "XEmacs\\|Lucid" emacs-version)
'(message-font-lock-keywords t)))
(make-local-variable 'adaptive-fill-regexp)
(setq adaptive-fill-regexp
- (concat "[ \t]*[-a-z0-9A-Z]*\\(>[ \t]*\\)+[ \t]*\\|" 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]*\\)+[ \t]*\\|"
+ (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|"
adaptive-fill-first-line-regexp))
- (make-local-variable 'auto-fill-inhibit-regexp)
- (setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:")
- (mm-enable-multibyte)
- (make-local-variable 'indent-tabs-mode) ;Turn off tabs for indentation.
- (setq indent-tabs-mode nil)
- (mml-mode)
(run-hooks 'text-mode-hook 'message-mode-hook))
\f
(interactive)
(if (looking-at "[ \t]*\n") (expand-abbrev))
(goto-char (point-min))
- (or (search-forward (concat "\n" mail-header-separator "\n") nil t)
- (search-forward "\n\n" nil t)))
+ (search-forward (concat "\n" mail-header-separator "\n") nil t))
(defun message-goto-eoh ()
"Move point to the end of the headers."
(interactive)
(message-goto-body)
- (forward-line -1))
+ (forward-line -2))
(defun message-goto-signature ()
"Move point to the beginning of the message signature.
(let ((co (message-fetch-reply-field "mail-copies-to")))
(when (and (null force)
co
- (or (equal (downcase co) "never")
- (equal (downcase co) "nobody")))
+ (equal (downcase co) "never"))
(error "The user has requested not to have copies sent via mail")))
(when (and (message-position-on-field "To")
(mail-fetch-field "to")
(insert (or (message-fetch-reply-field "reply-to")
(message-fetch-reply-field "from") "")))
-(defun message-widen-reply ()
- "Widen the reply to include maximum recipients."
- (interactive)
- (let ((follow-to
- (and message-reply-buffer
- (buffer-name message-reply-buffer)
- (save-excursion
- (set-buffer message-reply-buffer)
- (message-get-reply-headers t)))))
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (dolist (elem follow-to)
- (message-remove-header (symbol-name (car elem)))
- (goto-char (point-min))
- (insert (symbol-name (car elem)) ": "
- (cdr elem) "\n"))))))
-
(defun message-insert-newsgroups ()
"Insert the Newsgroups header from the article being replied to."
(interactive)
(defun message-newline-and-reformat ()
"Insert four newlines, and then reformat if inside quoted text."
(interactive)
- (let ((prefix "[]>»|:}+ \t]*")
- (supercite-thing "[-._a-zA-Z0-9]*[>]+[ \t]*")
- quoted point)
- (unless (bolp)
- (save-excursion
- (beginning-of-line)
- (when (looking-at (concat prefix
- supercite-thing))
- (setq quoted (match-string 0))))
- (insert "\n"))
- (setq point (point))
- (insert "\n\n\n")
- (delete-region (point) (re-search-forward "[ \t]*"))
+ (let ((point (point))
+ quoted)
+ (save-excursion
+ (beginning-of-line)
+ (setq quoted (looking-at (regexp-quote message-yank-prefix))))
+ (insert "\n\n\n\n")
(when quoted
- (insert quoted))
+ (insert message-yank-prefix))
(fill-paragraph nil)
(goto-char point)
- (forward-line 1)))
+ (forward-line 2)))
(defun message-insert-signature (&optional force)
"Insert a signature. See documentation for the `message-signature' variable."
(eq force 0))
(save-excursion
(goto-char (point-max))
- (not (re-search-backward message-signature-separator nil t))))
+ (not (re-search-backward
+ message-signature-separator nil t))))
((and (null message-signature)
force)
t)
(defun message-elide-region (b e)
"Elide the text between point and mark.
-An ellipsis (from `message-elide-ellipsis') will be inserted where the
+An ellipsis (from `message-elide-elipsis') will be inserted where the
text was killed."
(interactive "r")
(kill-region b e)
- (insert message-elide-ellipsis))
+ (unless (bolp)
+ (insert "\n"))
+ (insert message-elide-elipsis))
(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)))
- (translate-region b e message-caesar-translation-table)))
+ (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)
+ (subst-char-in-region
+ b (1+ b) (char-after b)
+ (aref message-caesar-translation-table (char-after b)))
+ (incf b))))
(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)))
- (shell-command-on-region
- (point-min) (point-max) program nil t))))
+ (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))))))
(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))))
+ (fill-individual-paragraphs (point) (point-max) justifyp t))))
(defun message-indent-citation ()
"Modify text just inserted from a message to be cited.
(forward-line 1))))
(goto-char start)))
+(defvar gnus-article-copy)
(defun message-yank-original (&optional arg)
"Insert the message being replied to, if any.
Puts point before the text and mark after.
Just \\[universal-argument] as argument means don't indent, insert no
prefix, and don't delete any headers."
(interactive "P")
- (let ((modified (buffer-modified-p)))
- (when (and message-reply-buffer
+ (let ((modified (buffer-modified-p))
+ (buffer (message-eval-parameter message-reply-buffer)))
+ (when (and buffer
message-cite-function)
- (delete-windows-on message-reply-buffer t)
- (insert-buffer message-reply-buffer)
+ (delete-windows-on buffer t)
+ (insert-buffer buffer)
(funcall message-cite-function)
(message-exchange-point-and-mark)
(unless (bolp)
(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)))))
- (mml-quote-region start end)
- ;; Allow undoing.
- (undo-boundary)
(goto-char end)
- (when (re-search-backward message-signature-separator start t)
+ (when (re-search-backward "^-- $" start t)
;; Also peel off any blank lines before the signature.
(forward-line -1)
(while (looking-at "^[ \t]*$")
(insert "\n"))
(funcall message-citation-line-function))))
-(defvar mail-citation-hook) ;Compiler directive
+(defvar mail-citation-hook) ;Compiler directive
(defun message-cite-original ()
"Cite function in the standard Message manner."
(if (and (boundp 'mail-citation-hook)
mail-citation-hook)
(run-hooks 'mail-citation-hook)
(let ((start (point))
- (end (mark t))
(functions
(when message-indent-citation-function
(if (listp message-indent-citation-function)
message-indent-citation-function
(list message-indent-citation-function)))))
- (mml-quote-region start end)
(goto-char start)
(while functions
(funcall (pop functions)))
;;; Sending messages
;;;
+;; Avoid byte-compile warning.
+(defvar message-encoding-buffer nil)
+(defvar message-edit-buffer nil)
+(defvar message-mime-mode nil)
+
(defun message-send-and-exit (&optional arg)
"Send message like `message-send', then, if no errors, exit from mail buffer."
(interactive "P")
(let ((buf (current-buffer))
- (actions message-exit-actions))
+ (actions message-exit-actions)
+ (frame (selected-frame))
+ (org-frame message-original-frame))
(when (and (message-send arg)
(buffer-name buf))
(if message-kill-buffer-on-exit
(when (eq buf (current-buffer))
(message-bury buf)))
(message-do-actions actions)
+ (message-delete-frame frame org-frame)
t)))
(defun message-dont-send ()
(interactive)
(set-buffer-modified-p t)
(save-buffer)
- (let ((actions message-postpone-actions))
+ (let ((actions message-postpone-actions)
+ (frame (selected-frame))
+ (org-frame message-original-frame))
(message-bury (current-buffer))
- (message-do-actions actions)))
+ (message-do-actions actions)
+ (message-delete-frame frame org-frame)))
(defun message-kill-buffer ()
"Kill the current buffer."
(interactive)
(when (or (not (buffer-modified-p))
- (yes-or-no-p "Message modified; kill anyway? "))
- (let ((actions message-kill-actions))
+ (eq t message-kill-buffer-query-function)
+ (funcall message-kill-buffer-query-function
+ "The buffer modified; kill anyway? "))
+ (let ((actions message-kill-actions)
+ (frame (selected-frame))
+ (org-frame message-original-frame))
(setq buffer-file-name nil)
(kill-buffer (current-buffer))
- (message-do-actions actions))))
+ (message-do-actions actions)
+ (message-delete-frame frame org-frame)))
+ (message ""))
+
+(defun message-mimic-kill-buffer ()
+ "Kill the current buffer with query."
+ (interactive)
+ (unless (eq 'message-mode major-mode)
+ (error "%s must be invoked from a message buffer." this-command))
+ (let ((command this-command)
+ (bufname (read-buffer (format "Kill buffer: (default %s) "
+ (buffer-name)))))
+ (if (or (not bufname)
+ (string-equal bufname "")
+ (string-equal bufname (buffer-name)))
+ (message-kill-buffer)
+ (message "%s must be invoked only for the current buffer." command))))
+
+(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
+ (>= emacs-major-version 20))
+ (or (and (eq message-delete-frame-on-exit t)
+ (select-frame frame)
+ (or (eq frame org-frame)
+ (prog1
+ (y-or-n-p "Delete this frame?")
+ (message ""))))
+ (and (eq message-delete-frame-on-exit 'ask)
+ (select-frame frame)
+ (prog1
+ (y-or-n-p "Delete this frame?")
+ (message "")))))
+ (delete-frame frame)))
(defun message-bury (buffer)
"Bury this mail buffer."
(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.
-The usage of ARG is defined by the instance that called Message.
-It should typically alter the sending method in some way or other."
+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."
(interactive "P")
- ;; Make it possible to undo the coming changes.
- (undo-boundary)
- (let ((inhibit-read-only t))
- (put-text-property (point-min) (point-max) 'read-only nil))
- (message-fix-before-sending)
- (run-hooks 'message-send-hook)
- (message "Sending...")
- (let ((alist message-send-method-alist)
- (success t)
- elem sent)
- (while (and success
- (setq elem (pop alist)))
- (when (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)))
- (unless (or sent (not success))
- (error "No methods specified to send by"))
- (when (and success sent)
- (message-do-fcc)
+ ;; Disabled test.
+ (when (or (buffer-modified-p)
+ (message-check-element 'unchanged)
+ (y-or-n-p "No changes in the buffer; really send? "))
+ ;; Make it possible to undo the coming changes.
+ (undo-boundary)
+ (let ((inhibit-read-only t))
+ (put-text-property (point-min) (point-max) 'read-only nil))
+ (run-hooks 'message-send-hook)
+ (message "Sending...")
+ (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)
(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)))
+ (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 (and success sent)
+ (message-do-fcc)
+ ;;(when (fboundp 'mail-hist-put-headers-into-history)
+ ;; (mail-hist-put-headers-into-history))
+ (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))))
(defun message-send-via-mail (arg)
"Send the current message via mail."
(defun message-send-via-news (arg)
"Send the current message via news."
- (funcall message-send-news-function arg))
-
-(defmacro message-check (type &rest forms)
- "Eval FORMS if TYPE is to be checked."
- `(or (message-check-element ,type)
- (save-excursion
- ,@forms)))
-
-(put 'message-check 'lisp-indent-function 1)
-(put 'message-check 'edebug-form-spec '(form body))
+ (message-send-news arg))
(defun message-fix-before-sending ()
"Do various things to make the message nice before sending it."
(goto-char (point-max))
(unless (bolp)
(insert "\n"))
- ;; Delete all invisible text.
- (message-check 'invisible-text
- (when (text-property-any (point-min) (point-max) 'invisible t)
- (put-text-property (point-min) (point-max) 'invisible nil)
- (unless (yes-or-no-p
- "Invisible text found and made visible; continue posting? ")
- (error "Invisible text found and made visible")))))
+ ;; Make all invisible text visible.
+ ;;(when (text-property-any (point-min) (point-max) 'invisible t)
+ ;; (put-text-property (point-min) (point-max) 'invisible nil)
+ ;; (unless (yes-or-no-p "Invisible text found and made visible; continue posting?")
+ ;; (error "Invisible text found and made visible")))
+ )
(defun message-add-action (action &rest types)
"Add ACTION to be performed when doing an exit of type TYPES."
(defun message-send-mail (&optional arg)
(require 'mail-utils)
- (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
- (case-fold-search nil)
- (news (message-news-p))
- (mailbuf (current-buffer))
- (message-this-is-mail t)
- (message-posting-charset
- (if (fboundp 'gnus-setup-posting-charset)
- (gnus-setup-posting-charset nil)
- message-posting-charset)))
+ (let ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
+ (case-fold-search nil)
+ (news (message-news-p)))
(save-restriction
(message-narrow-to-headers)
;; Insert some headers.
(message-generate-headers message-required-mail-headers))
;; Let the user do all of the above.
(run-hooks 'message-header-hook))
- (unwind-protect
- (save-excursion
- (set-buffer tembuf)
- (erase-buffer)
- ;; Avoid copying text props.
- (insert (format
- "%s" (save-excursion
- (set-buffer mailbuf)
- (buffer-string))))
- ;; Remove some headers.
- (message-encode-message-body)
- (save-restriction
- (message-narrow-to-headers)
- ;; We (re)generate the Lines header.
- (when (memq 'Lines message-required-mail-headers)
- (message-generate-headers '(Lines)))
+ (if (not (message-check-mail-syntax))
+ (progn
+ (message "")
+ ;;(message "Posting not performed")
+ nil)
+ (unwind-protect
+ (save-excursion
+ (set-buffer tembuf)
+ (erase-buffer)
+ (insert-buffer message-encoding-buffer)
;; Remove some headers.
- (message-remove-header message-ignored-mail-headers t)
- (mail-encode-encoded-word-buffer))
- (goto-char (point-max))
- ;; require one newline at the end.
- (or (= (preceding-char) ?\n)
- (insert ?\n))
- (when (and news
- (or (message-fetch-field "cc")
- (message-fetch-field "to")))
- (message-insert-courtesy-copy))
- (funcall message-send-mail-function))
- (kill-buffer tembuf))
- (set-buffer mailbuf)
- (push 'mail message-sent-message-via)))
+ (save-restriction
+ (message-narrow-to-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
+ (or (message-fetch-field "cc")
+ (message-fetch-field "to")))
+ (message-insert-courtesy-copy))
+ (mime-edit-maybe-split-and-send
+ (function
+ (lambda ()
+ (interactive)
+ (funcall message-send-mail-function)
+ )))
+ (funcall message-send-mail-function))
+ (kill-buffer tembuf))
+ (set-buffer message-edit-buffer)
+ (push 'mail message-sent-message-via))))
(defun message-send-mail-with-sendmail ()
"Send off the prepared buffer with sendmail."
(let ((errbuf (if message-interactive
- (message-generate-new-buffer-clone-locals
- " sendmail errors")
+ (generate-new-buffer " sendmail errors")
0))
resend-to-addresses delimline)
(let ((case-fold-search t))
(save-excursion
(set-buffer errbuf)
(erase-buffer))))
- (let ((default-directory "/")
- (coding-system-for-write message-send-coding-system))
- (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")))))
+ (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" (user-login-name)))
+ ;; 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)
(run-hooks 'message-send-mail-hook)
;; send the message
(case
- (let ((coding-system-for-write message-send-coding-system))
- (apply
- 'call-process-region 1 (point-max) message-qmail-inject-program
- nil nil nil
- ;; qmail-inject's default behaviour is to look for addresses on the
- ;; command line; if there're none, it scans the headers.
- ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin.
- ;;
- ;; in general, ALL of qmail-inject's defaults are perfect for simply
- ;; reading a formatted (i. e., at least a To: or Resent-To header)
- ;; message from stdin.
- ;;
- ;; qmail also has the advantage of not having been raped by
- ;; various vendors, so we don't have to allow for that, either --
- ;; compare this with message-send-mail-with-sendmail and weep
- ;; for sendmail's lost innocence.
- ;;
- ;; all this is way cool coz it lets us keep the arguments entirely
- ;; 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))
+ (as-binary-process
+ (apply
+ 'call-process-region 1 (point-max) message-qmail-inject-program
+ nil nil nil
+ ;; qmail-inject's default behaviour is to look for addresses on the
+ ;; command line; if there're none, it scans the headers.
+ ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin.
+ ;;
+ ;; in general, ALL of qmail-inject's defaults are perfect for simply
+ ;; reading a formatted (i. e., at least a To: or Resent-To header)
+ ;; message from stdin.
+ ;;
+ ;; qmail also has the advantage of not having been raped by
+ ;; various vendors, so we don't have to allow for that, either --
+ ;; compare this with message-send-mail-with-sendmail and weep
+ ;; for sendmail's lost innocence.
+ ;;
+ ;; all this is way cool coz it lets us keep the arguments entirely
+ ;; 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))
;; qmail-inject doesn't say anything on it's stdout/stderr,
;; we have to look at the retval instead
(0 nil)
;; Pass it on to mh.
(mh-send-letter)))
+(defun message-send-mail-with-smtp ()
+ "Send the prepared message buffer with SMTP."
+ (require 'smtp)
+ (let ((errbuf (if mail-interactive
+ (generate-new-buffer " smtp errors")
+ 0))
+ (case-fold-search nil)
+ resend-to-addresses
+ delimline)
+ (unwind-protect
+ (save-excursion
+ (goto-char (point-max))
+ ;; require one newline at the end.
+ (or (= (preceding-char) ?\n)
+ (insert ?\n))
+ ;; 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)
+ ;; (sendmail-synch-aliases)
+ ;; (if mail-aliases
+ ;; (expand-mail-aliases (point-min) delimline))
+ (goto-char (point-min))
+ ;; ignore any blank lines in the header
+ (while (and (re-search-forward "\n\n\n*" delimline t)
+ (< (point) delimline))
+ (replace-match "\n"))
+ (let ((case-fold-search t))
+ (goto-char (point-min))
+ (goto-char (point-min))
+ (while (re-search-forward "^Resent-to:" delimline t)
+ (setq resend-to-addresses
+ (save-restriction
+ (narrow-to-region (point)
+ (save-excursion
+ (end-of-line)
+ (point)))
+ (append (mail-parse-comma-list)
+ resend-to-addresses))))
+;;; Apparently this causes a duplicate Sender.
+;;; ;; If the From is different than current user, insert Sender.
+;;; (goto-char (point-min))
+;;; (and (re-search-forward "^From:" delimline t)
+;;; (progn
+;;; (require 'mail-utils)
+;;; (not (string-equal
+;;; (mail-strip-quoted-names
+;;; (save-restriction
+;;; (narrow-to-region (point-min) delimline)
+;;; (mail-fetch-field "From")))
+;;; (user-login-name))))
+;;; (progn
+;;; (forward-line 1)
+;;; (insert "Sender: " (user-login-name) "\n")))
+ ;; Don't send out a blank subject line
+ (goto-char (point-min))
+ (if (re-search-forward "^Subject:[ \t]*\n" delimline t)
+ (replace-match ""))
+ ;; Put the "From:" field in unless for some odd reason
+ ;; they put one in themselves.
+ (goto-char (point-min))
+ (if (not (re-search-forward "^From:" delimline t))
+ (let* ((login user-mail-address)
+ (fullname (user-full-name)))
+ (cond ((eq mail-from-style 'angles)
+ (insert "From: " fullname)
+ (let ((fullname-start (+ (point-min) 6))
+ (fullname-end (point-marker)))
+ (goto-char fullname-start)
+ ;; Look for a character that cannot appear unquoted
+ ;; according to RFC 822.
+ (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]"
+ fullname-end 1)
+ (progn
+ ;; Quote fullname, escaping specials.
+ (goto-char fullname-start)
+ (insert "\"")
+ (while (re-search-forward "[\"\\]"
+ fullname-end 1)
+ (replace-match "\\\\\\&" t))
+ (insert "\""))))
+ (insert " <" login ">\n"))
+ ((eq mail-from-style 'parens)
+ (insert "From: " login " (")
+ (let ((fullname-start (point)))
+ (insert fullname)
+ (let ((fullname-end (point-marker)))
+ (goto-char fullname-start)
+ ;; RFC 822 says \ and nonmatching parentheses
+ ;; must be escaped in comments.
+ ;; Escape every instance of ()\ ...
+ (while (re-search-forward "[()\\]" fullname-end 1)
+ (replace-match "\\\\\\&" t))
+ ;; ... then undo escaping of matching parentheses,
+ ;; including matching nested parentheses.
+ (goto-char fullname-start)
+ (while (re-search-forward
+ "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
+ fullname-end 1)
+ (replace-match "\\1(\\3)" t)
+ (goto-char fullname-start))))
+ (insert ")\n"))
+ ((null mail-from-style)
+ (insert "From: " login "\n")))))
+ ;; Insert an extra newline if we need it to work around
+ ;; Sun's bug that swallows newlines.
+ (goto-char (1+ delimline))
+ (if (eval mail-mailer-swallows-blank-line)
+ (newline))
+ ;; Find and handle any FCC fields.
+ (goto-char (point-min))
+ (if (re-search-forward "^FCC:" delimline t)
+ (mail-do-fcc delimline))
+ (if mail-interactive
+ (save-excursion
+ (set-buffer errbuf)
+ (erase-buffer))))
+ ;;
+ ;;
+ ;;
+ (let ((recipient-address-list
+ (or resend-to-addresses
+ (smtp-deduce-address-list (current-buffer)
+ (point-min) delimline))))
+ (smtp-do-bcc delimline)
+
+ (if recipient-address-list
+ (if (not (smtp-via-smtp recipient-address-list
+ (current-buffer)))
+ (error "Sending failed; SMTP protocol error"))
+ (error "Sending failed; no recipients"))
+ ))
+ (if (bufferp errbuf)
+ (kill-buffer errbuf)))))
+
(defun message-send-news (&optional arg)
- (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
- (case-fold-search nil)
- (method (if (message-functionp message-post-method)
- (funcall message-post-method arg)
- message-post-method))
- (messbuf (current-buffer))
- (message-syntax-checks
- (if arg
- (cons '(existing-newsgroups . disabled)
- message-syntax-checks)
- message-syntax-checks))
- (message-this-is-news t)
- (message-posting-charset (gnus-setup-posting-charset
- (message-fetch-field "Newsgroups")))
- result)
- (if (not (message-check-news-body-syntax))
- nil
- (save-restriction
- (message-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))
- (message-cleanup-headers)
- (if (not (message-check-news-syntax))
- nil
- (unwind-protect
- (save-excursion
- (set-buffer tembuf)
- (buffer-disable-undo)
- (erase-buffer)
- ;; Avoid copying text props.
- (insert (format
- "%s" (save-excursion
- (set-buffer messbuf)
- (buffer-string))))
- (message-encode-message-body)
+ (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)
+ (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))
+ (message-cleanup-headers)
+ (if (not (message-check-news-syntax))
+ (progn
+ ;;(message "Posting not performed")
+ nil)
+ (unwind-protect
+ (save-excursion
+ (set-buffer tembuf)
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (insert-buffer message-encoding-buffer)
+ ;; Remove some headers.
+ (save-restriction
+ (message-narrow-to-headers)
;; 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-news-headers t)
- (let ((mail-parse-charset (car message-posting-charset)))
- (mail-encode-encoded-word-buffer)))
- (goto-char (point-max))
- ;; require one newline at the end.
- (or (= (preceding-char) ?\n)
- (insert ?\n))
- (let ((case-fold-search t))
- ;; Remove the delimiter.
- (goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "\n"))
- (replace-match "\n")
- (backward-char 1))
- (run-hooks 'message-send-news-hook)
- (gnus-open-server method)
- (setq result (let ((mail-header-separator ""))
- (gnus-request-post method))))
- (kill-buffer tembuf))
- (set-buffer messbuf)
- (if result
- (push 'news message-sent-message-via)
- (message "Couldn't send message via news: %s"
- (nnheader-get-report (car method)))
- nil)))))
+ (message-remove-header message-ignored-news-headers t))
+ (goto-char (point-max))
+ ;; require one newline at the end.
+ (or (= (preceding-char) ?\n)
+ (insert ?\n))
+ (mime-edit-maybe-split-and-send
+ (function
+ (lambda ()
+ (interactive)
+ (save-restriction
+ (std11-narrow-to-header mail-header-separator)
+ (goto-char (point-min))
+ (when (re-search-forward "^Message-Id:" nil t)
+ (delete-region (match-end 0)(std11-field-end))
+ (insert (concat " " (message-make-message-id)))
+ ))
+ (funcall message-send-news-function method)
+ )))
+ (setq result (funcall message-send-news-function method)))
+ (kill-buffer tembuf))
+ (set-buffer message-edit-buffer)
+ (if result
+ (push 'news message-sent-message-via)
+ (message "Couldn't send message via news: %s"
+ (nnheader-get-report (car method)))
+ nil))))
+
+;; 1997-09-29 by MORIOKA Tomohiko
+(defun message-send-news-with-gnus (method)
+ (let ((case-fold-search t))
+ ;; Remove the delimiter.
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n"))
+ (replace-match "\n")
+ (backward-char 1)
+ (run-hooks 'message-send-news-hook)
+ ;;(require (car method))
+ ;;(funcall (intern (format "%s-open-server" (car method)))
+ ;;(cadr method) (cddr method))
+ ;;(setq result
+ ;; (funcall (intern (format "%s-request-post" (car method)))
+ ;; (cadr method)))
+ (gnus-open-server method)
+ (gnus-request-post method)
+ ))
;;;
;;; Header generation & syntax checking.
;;;
+(defmacro message-check (type &rest forms)
+ "Eval FORMS if TYPE is to be checked."
+ `(or (message-check-element ,type)
+ (save-excursion
+ ,@forms)))
+
+(put 'message-check 'lisp-indent-function 1)
+(put 'message-check 'edebug-form-spec '(form body))
+
(defun message-check-element (type)
"Returns non-nil if this type is not to be checked."
(if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me)
(save-excursion
(save-restriction
(widen)
- ;; We narrow to the headers and check them first.
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (message-check-news-header-syntax))))))
+ (and
+ ;; We narrow to the headers and check them first.
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-check-news-header-syntax)))
+ ;; Check the body.
+ (save-excursion
+ (set-buffer message-edit-buffer)
+ (message-check-news-body-syntax))))))
(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)
+ (ad (nth 1 (mail-extract-address-components from))))
(cond
((not from)
(message "There is no From line. Posting is denied.")
nil)
- ((or (not (string-match
- "@[^\\.]*\\."
- (setq ad (nth 1 (mail-extract-address-components
- from))))) ;larsi@ifi
+ ((or (not (string-match "@[^\\.]*\\." ad)) ;larsi@ifi
(string-match "\\.\\." ad) ;larsi@ifi..uio
(string-match "@\\." ad) ;larsi@.ifi.uio
(string-match "\\.$" ad) ;larsi@ifi.uio.
(y-or-n-p "Empty article. Really post? "))))
;; Check for control characters.
(message-check 'control-chars
- (if (re-search-forward "[\000-\007\013\015-\032\034-\037\200-\237]" nil t)
+ (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t)
(y-or-n-p
"The article contains control characters. Really post? ")
t))
+ ;; Check 8bit characters.
+ (message-check '8bit
+ (message-check-8bit))
;; Check excessive size.
(message-check 'size
(if (> (buffer-size) 60000)
;; Check the length of the signature.
(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))))
+ (if (or (not (re-search-backward message-signature-separator nil t))
+ (search-forward message-forward-end-separator nil t))
+ t
+ (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)))))
+
+(defun message-check-mail-syntax ()
+ "Check the syntax of the message."
+ (save-excursion
+ (save-restriction
+ (widen)
+ (and
+ ;; We narrow to the headers and check them first.
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-check-mail-header-syntax)))
+ ;; Check the body.
+ (save-excursion
+ (set-buffer message-edit-buffer)
+ (message-check-mail-body-syntax))))))
+
+(defun message-check-mail-header-syntax ()
+ t)
+
+(defun message-check-mail-body-syntax ()
+ (and
+ ;; Check 8bit characters.
+ (message-check '8bit
+ (message-check-8bit)
+ )))
+
+(defun message-check-8bit ()
+ "Check the article contains 8bit characters."
+ (save-excursion
+ (set-buffer message-encoding-buffer)
+ (message-narrow-to-headers)
+ (let* ((case-fold-search t)
+ (field-value (message-fetch-field "content-transfer-encoding")))
+ (if (and field-value
+ (member (downcase field-value) message-8bit-encoding-list))
+ t
+ (widen)
+ (set-buffer (get-buffer-create " message syntax"))
+ (erase-buffer)
+ (goto-char (point-min))
+ (set-buffer-multibyte nil)
+ (insert-buffer message-encoding-buffer)
+ (goto-char (point-min))
+ (if (re-search-forward "[^\x00-\x7f]" nil t)
+ (y-or-n-p
+ "The article contains 8bit characters. Really post? ")
+ t)))))
(defun message-checksum ()
"Return a \"checksum\" for the current buffer."
(while (not (eobp))
(when (not (looking-at "[ \t\n]"))
(setq sum (logxor (ash sum 1) (if (natnump sum) 0 1)
- (char-after))))
+ (following-char))))
(forward-char 1)))
sum))
(defun message-do-fcc ()
"Process Fcc headers in the current buffer."
(let ((case-fold-search t)
- (buf (current-buffer))
+ (coding-system-for-write 'raw-text)
list file)
(save-excursion
(set-buffer (get-buffer-create " *message temp*"))
+ (buffer-disable-undo (current-buffer))
(erase-buffer)
- (insert-buffer-substring buf)
+ (insert-buffer-substring message-encoding-buffer)
(save-restriction
(message-narrow-to-headers)
(while (setq file (message-fetch-field "fcc"))
"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 ()
(when (re-search-forward ",+$" nil t)
(replace-match "" t t))))))
-(defun message-make-date (&optional now)
- "Make a valid data header.
-If NOW, use that time instead."
- (let* ((now (or now (current-time)))
- (zone (nth 8 (decode-time now)))
- (sign "+"))
- (when (< zone 0)
- (setq sign "-")
- (setq zone (- zone)))
- (concat
- (format-time-string "%d" now)
- ;; The month name of the %b spec is locale-specific. Pfff.
- (format " %s "
- (capitalize (car (rassoc (nth 4 (decode-time now))
- 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) 60)))))
+(defun message-make-date ()
+ "Make a valid data header."
+ (let ((now (current-time)))
+ (timezone-make-date-arpa-standard
+ (current-time-string now) (current-time-zone now))))
(defun message-make-message-id ()
"Make a unique Message-ID."
"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)
"Return the In-Reply-To header for this message."
(when message-reply-headers
(let ((from (mail-header-from message-reply-headers))
- (date (mail-header-date message-reply-headers)))
- (when from
- (let ((stop-pos
- (string-match " *at \\| *@ \\| *(\\| *<" from)))
- (concat (if (and stop-pos
- (not (zerop stop-pos)))
- (substring from 0 stop-pos) from)
- "'s message of \""
- (if (or (not date) (string= date ""))
- "(unknown date)" date)
- "\""))))))
+ (date (mail-header-date message-reply-headers))
+ (msg-id (mail-header-message-id message-reply-headers)))
+ (when msg-id
+ (concat msg-id
+ (when from
+ (let ((stop-pos
+ (string-match " *at \\| *@ \\| *(\\| *<" from)))
+ (concat " ("
+ (if (and stop-pos
+ (not (zerop stop-pos)))
+ (substring from 0 stop-pos) from)
+ "'s message of \""
+ (if (or (not date) (string= date ""))
+ "(unknown date)" date)
+ "\")"))))))))
(defun message-make-distribution ()
"Make a Distribution header."
;; Add the future to current.
(setcar current (+ (car current) (round (/ future (expt 2 16)))))
(setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16))))
- (message-make-date current)))
+ ;; Return the date in the future in UT.
+ (timezone-make-date-arpa-standard
+ (current-time-string current) (current-time-zone current) '(0 "UT"))))
(defun message-make-path ()
"Return uucp path."
(or mail-host-address
(message-make-fqdn)))
+(defun message-make-user-agent ()
+ "Return user-agent info."
+ (if message-user-agent
+ (save-excursion
+ (goto-char (point-min))
+ (let ((case-fold-search t)
+ user-agent beg p end)
+ (if (re-search-forward "^User-Agent:[ \t]*" nil t)
+ (progn
+ (setq beg (match-beginning 0)
+ p (match-end 0)
+ end (std11-field-end)
+ user-agent (buffer-substring p end))
+ (delete-region beg (1+ end))
+ (concat message-user-agent " " user-agent)
+ )
+ message-user-agent)))))
+
(defun message-generate-headers (headers)
"Prepare article HEADERS.
Headers already prepared in the buffer are not modified."
(To nil)
(Distribution (message-make-distribution))
(Lines (message-make-lines))
- (User-Agent message-newsreader)
+ (User-Agent (message-make-user-agent))
(Expires (message-make-expires))
(case-fold-search t)
header value elem)
(progn
;; The header was found. We insert a space after the
;; colon, if there is none.
- (if (/= (char-after) ? ) (insert " ") (forward-char 1))
+ (if (/= (following-char) ? ) (insert " ") (forward-char 1))
;; Find out whether the header is empty...
- (looking-at "[ \t]*\n[^ \t]")))
+ (looking-at "[ \t]*$")))
;; So we find out what value we should insert.
(setq value
(cond
;; The element is a symbol. We insert the value
;; of this symbol, if any.
(symbol-value header))
- ((not (message-check-element header))
+ (t
;; We couldn't generate a value for this header,
;; so we just ask the user.
(read-from-minibuffer
(goto-char (point-min))
(while (not (eobp))
(skip-chars-forward "^,\"" (point-max))
- (if (or (eq (char-after) ?,)
+ (if (or (= (following-char) ?,)
(eobp))
(when (not quoted)
(if (and (> (current-column) 78)
(widen)
(forward-line 1)))
+(defun message-fill-references (header value)
+ (insert (capitalize (symbol-name header))
+ ": "
+ (std11-fill-msg-id-list-string
+ (if (consp value) (car value) value))
+ "\n"))
+
(defun message-fill-header (header value)
(let ((begin (point))
- (fill-column 78)
+ (fill-column 990)
(fill-prefix "\t"))
(insert (capitalize (symbol-name header))
": "
(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)
- "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)
+ "Limit REFERENCES to be shorter than 988 characters."
+ (let ((max 988)
+ (cut 4)
refs)
- (with-temp-buffer
+ (nnheader-temp-write nil
(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)
- 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)))))
+ (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")))
(defun message-position-point ()
"Move point to where the user probably wants to find it."
(search-backward ":" )
(widen)
(forward-char 1)
- (if (eq (char-after) ? )
+ (if (= (following-char) ? )
(forward-char 1)
(insert " ")))
(t
(defun message-buffer-name (type &optional to group)
"Return a new (unique) buffer name based on TYPE and TO."
(cond
- ;; Generate a new buffer name The Message Way.
- ((eq message-generate-new-buffers 'unique)
- (generate-new-buffer-name
- (concat "*" type
- (if to
- (concat " to "
- (or (car (mail-extract-address-components to))
- to) "")
- "")
- (if (and group (not (string= group ""))) (concat " on " group) "")
- "*")))
;; Check whether `message-generate-new-buffers' is a function,
;; and if so, call it.
((message-functionp message-generate-new-buffers)
(funcall message-generate-new-buffers type to group))
- ((eq message-generate-new-buffers 'unsent)
+ ;; Generate a new buffer name The Message Way.
+ (message-generate-new-buffers
(generate-new-buffer-name
- (concat "*unsent " type
+ (concat "*" type
(if to
(concat " to "
(or (car (mail-extract-address-components to))
(defun message-pop-to-buffer (name)
"Pop to buffer NAME, and warn if it already exists and is modified."
- (let ((buffer (get-buffer name)))
+ (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))
(if (and buffer
(buffer-name buffer))
(progn
(error "Message being composed")))
(set-buffer (pop-to-buffer name)))
(erase-buffer)
- (message-mode)))
+ (message-mode)
+ (when pop-up-frames
+ (make-local-variable 'message-original-frame)
+ (setq message-original-frame (selected-frame)))))
(defun message-do-send-housekeeping ()
"Kill old message buffers."
;; Rename the buffer.
(if message-send-rename-function
(funcall message-send-rename-function)
- (when (string-match "\\`\\*\\(unsent \\)?" (buffer-name))
+ (when (string-match "\\`\\*" (buffer-name))
(rename-buffer
(concat "*sent " (substring (buffer-name) (match-end 0))) t)))
;; Push the current buffer onto the list.
mc-modes-alist))
(when actions
(setq message-send-actions actions))
- (setq message-reply-buffer replybuffer)
+ (setq message-reply-buffer
+ (or (message-get-parameter 'reply-buffer)
+ replybuffer))
(goto-char (point-min))
;; Insert all the headers.
(mail-header-format
(setq buffer-file-name (expand-file-name "*message*"
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)))
+ (clear-visited-file-modtime)))
(defun message-disassociate-draft ()
"Disassociate the message buffer from the drafts directory."
(nndraft-request-expire-articles
(list message-draft-article) "drafts" nil t)))
-(defun message-insert-headers ()
- "Generate the headers for the article."
- (interactive)
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (when (message-news-p)
- (message-generate-headers
- (delq 'Lines
- (delq 'Subject
- (copy-sequence message-required-news-headers)))))
- (when (message-mail-p)
- (message-generate-headers
- (delq 'Lines
- (delq 'Subject
- (copy-sequence message-required-mail-headers))))))))
-
\f
;;;
(message-setup `((Newsgroups . ,(or newsgroups ""))
(Subject . ,(or subject ""))))))
-(defun message-get-reply-headers (wide &optional to-address)
- (let (follow-to mct never-mct from to cc reply-to ccalist)
- ;; Find all relevant headers we need.
- (setq from (message-fetch-field "from")
- to (message-fetch-field "to")
- cc (message-fetch-field "cc")
- mct (message-fetch-field "mail-copies-to")
- reply-to (message-fetch-field "reply-to"))
-
- ;; Handle special values of Mail-Copies-To.
- (when mct
- (cond ((or (equal (downcase mct) "never")
- (equal (downcase mct) "nobody"))
- (setq never-mct t)
- (setq mct nil))
- ((or (equal (downcase mct) "always")
- (equal (downcase mct) "poster"))
- (setq mct (or reply-to from)))))
-
- (if (or (not wide)
- to-address)
- (progn
- (setq follow-to (list (cons 'To (or to-address reply-to from))))
- (when (and wide mct)
- (push (cons 'Cc mct) follow-to)))
- (let (ccalist)
- (save-excursion
- (message-set-work-buffer)
- (unless never-mct
- (insert (or reply-to from "")))
- (insert (if to (concat (if (bolp) "" ", ") to "") ""))
- (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
- (insert (if cc (concat (if (bolp) "" ", ") cc) ""))
- (goto-char (point-min))
- (while (re-search-forward "[ \t]+" nil t)
- (replace-match " " t t))
- ;; Remove addresses that match `rmail-dont-reply-to-names'.
- (let ((rmail-dont-reply-to-names message-dont-reply-to-names))
- (insert (prog1 (rmail-dont-reply-to (buffer-string))
- (erase-buffer))))
- (goto-char (point-min))
- ;; Perhaps "Mail-Copies-To: never" removed the only address?
- (when (eobp)
- (insert (or reply-to from "")))
- (setq ccalist
- (mapcar
- (lambda (addr)
- (cons (mail-strip-quoted-names addr) addr))
- (message-tokenize-header (buffer-string))))
- (let ((s ccalist))
- (while s
- (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
- (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
- (when ccalist
- (let ((ccs (cons 'Cc (mapconcat
- (lambda (addr) (cdr addr)) ccalist ", "))))
- (when (string-match "^ +" (cdr ccs))
- (setcdr ccs (substring (cdr ccs) (match-end 0))))
- (push ccs follow-to)))))
- follow-to))
-
-
;;;###autoload
(defun message-reply (&optional to-address wide)
"Start editing a reply to the article in the current buffer."
from subject date reply-to to cc
references message-id follow-to
(inhibit-point-motion-hooks t)
- (message-this-is-mail t)
- gnus-warning)
+ mct never-mct gnus-warning)
(save-restriction
(message-narrow-to-head)
;; Allow customizations to have their say.
(save-excursion
(setq follow-to
(funcall message-wide-reply-to-function)))))
- (setq message-id (message-fetch-field "message-id" t)
- references (message-fetch-field "references")
+ ;; Find all relevant headers we need.
+ (setq from (message-fetch-field "from")
date (message-fetch-field "date")
- from (message-fetch-field "from")
- subject (or (message-fetch-field "subject") "none"))
- ;; Remove any (buggy) Re:'s that are present and make a
- ;; proper one.
- (when (string-match message-subject-re-regexp subject)
- (setq subject (substring subject (match-end 0))))
- (setq subject (concat "Re: " subject))
-
- (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
- (string-match "<[^>]+>" gnus-warning))
- (setq message-id (match-string 0 gnus-warning)))
-
- (unless follow-to
- (setq follow-to (message-get-reply-headers wide to-address))))
-
- (message-pop-to-buffer
- (message-buffer-name
- (if wide "wide reply" "reply") from
- (if wide to-address nil)))
+ subject (or (message-fetch-field "subject") "none")
+ to (message-fetch-field "to")
+ cc (message-fetch-field "cc")
+ mct (message-fetch-field "mail-copies-to")
+ reply-to (message-fetch-field "reply-to")
+ references (message-fetch-field "references")
+ message-id (message-fetch-field "message-id" t))
+ ;; Remove any (buggy) Re:'s that are present and make a
+ ;; proper one.
+ (when (string-match message-subject-re-regexp subject)
+ (setq subject (substring subject (match-end 0))))
+ (setq subject (concat "Re: " subject))
+
+ (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
+ (string-match "<[^>]+>" gnus-warning))
+ (setq message-id (match-string 0 gnus-warning)))
+
+ ;; Handle special values of Mail-Copies-To.
+ (when mct
+ (cond ((equal (downcase mct) "never")
+ (setq never-mct t)
+ (setq mct nil))
+ ((equal (downcase mct) "always")
+ (setq mct (or reply-to from)))))
+
+ (unless follow-to
+ (if (or (not wide)
+ to-address)
+ (progn
+ (setq follow-to (list (cons 'To (or to-address reply-to from))))
+ (when (and wide mct)
+ (push (cons 'Cc mct) follow-to)))
+ (let (ccalist)
+ (save-excursion
+ (message-set-work-buffer)
+ (unless never-mct
+ (insert (or reply-to from "")))
+ (insert (if to (concat (if (bolp) "" ", ") to "") ""))
+ (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
+ (insert (if cc (concat (if (bolp) "" ", ") cc) ""))
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t]+" nil t)
+ (replace-match " " t t))
+ ;; Remove addresses that match `rmail-dont-reply-to-names'.
+ (insert (prog1 (rmail-dont-reply-to (buffer-string))
+ (erase-buffer)))
+ (goto-char (point-min))
+ ;; Perhaps Mail-Copies-To: never removed the only address?
+ (when (eobp)
+ (insert (or reply-to from "")))
+ (setq ccalist
+ (mapcar
+ (lambda (addr)
+ (cons (mail-strip-quoted-names addr) addr))
+ (message-tokenize-header (buffer-string))))
+ (let ((s ccalist))
+ (while s
+ (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
+ (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
+ (when ccalist
+ (let ((ccs (cons 'Cc (mapconcat
+ (lambda (addr) (cdr addr)) ccalist ", "))))
+ (when (string-match "^ +" (cdr ccs))
+ (setcdr ccs (substring (cdr ccs) (match-end 0))))
+ (push ccs follow-to))))))
+ (widen))
+
+ (message-pop-to-buffer (message-buffer-name
+ (if wide "wide reply" "reply") from
+ (if wide to-address nil)))
(setq message-reply-headers
(vector 0 subject from date message-id references 0 0 ""))
`((References . ,(concat (or references "") (and references " ")
(or message-id "")))))
,@(when (and mct
- (not (or (equal (downcase mct) "never")
- (equal (downcase mct) "nobody"))))
- (list (cons 'Cc (if (or (equal (downcase mct) "always")
- (equal (downcase mct) "poster"))
+ (not (equal (downcase mct) "never")))
+ (list (cons 'Cc (if (equal (downcase mct) "always")
(or reply-to from "")
mct)))))
;;;###autoload
-(defun message-cancel-news (&optional arg)
- "Cancel an article you posted.
-If ARG, allow editing of the cancellation message."
- (interactive "P")
+(defun message-cancel-news ()
+ "Cancel an article you posted."
+ (interactive)
(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-id (message-fetch-field "message-id" t)
distribution (message-fetch-field "distribution")))
;; Make sure that this article was written by the user.
- (unless (or (and sender
- (string-equal
- (downcase sender)
- (downcase (message-make-sender))))
- (string-equal
- (downcase (cadr (mail-extract-address-components from)))
- (downcase (cadr (mail-extract-address-components
- (message-make-from))))))
+ (unless (or (and sender
+ (string-equal
+ (downcase sender)
+ (downcase (message-make-sender))))
+ (string-equal
+ (downcase (cadr (mail-extract-address-components from)))
+ (downcase (cadr (mail-extract-address-components
+ (message-make-from))))))
(error "This article is not yours"))
;; Make control message.
- (if arg
- (message-news)
- (setq buf (set-buffer (get-buffer-create " *message cancel*"))))
+ (setq buf (set-buffer (get-buffer-create " *message cancel*")))
+ (buffer-disable-undo (current-buffer))
(erase-buffer)
(insert "Newsgroups: " newsgroups "\n"
"From: " (message-make-from) "\n"
"")
mail-header-separator "\n"
message-cancel-message)
- (run-hooks 'message-cancel-hook)
- (unless arg
- (message "Canceling your article...")
- (if (let ((message-syntax-checks
- 'dont-check-for-anything-just-trust-me))
- (funcall message-send-news-function))
- (message "Canceling your article...done"))
- (kill-buffer buf))))))
+ (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)))))
+
+(defun message-supersede-setup-for-mime-edit ()
+ (set (make-local-variable 'message-setup-hook) nil)
+ (mime-edit-again))
;;;###autoload
(defun message-supersede ()
(goto-char (point-max))
(insert mail-header-separator)
(widen)
- (forward-line 1)))
+ (when message-supersede-setup-function
+ (funcall message-supersede-setup-function))
+ (run-hooks 'message-supersede-setup-hook)
+ (goto-char (point-min))
+ (search-forward (concat "\n" mail-header-separator "\n") nil t)))
;;;###autoload
(defun message-recover ()
(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
(defun message-wash-subject (subject)
"Remove junk like \"Re:\", \"(fwd)\", etc. that was added to the subject by previous forwarders, replyers, etc."
- (with-temp-buffer
+ (nnheader-temp-write nil
(insert-string subject)
(goto-char (point-min))
;; strip Re/Fwd stuff off the beginning
(replace-match ""))
(buffer-string)))
-
+
;;; Forwarding messages.
(defun message-forward-subject-author-subject (subject)
(let ((funcs message-make-forward-subject-function)
(subject (if message-wash-forwarded-subjects
(message-wash-subject
- (or (message-fetch-field "Subject") ""))
- (or (message-fetch-field "Subject") ""))))
+ (or (eword-decode-unstructured-field-body
+ (message-fetch-field "Subject")) ""))
+ (or (eword-decode-unstructured-field-body
+ (message-fetch-field "Subject")) ""))))
;; Make sure funcs is a list.
(and funcs
(not (listp funcs))
(let ((cur (current-buffer))
(subject (message-make-forward-subject))
art-beg)
- (if news
- (message-news nil subject)
- (message-mail nil subject))
+ (if news (message-news nil subject) (message-mail nil subject))
;; Put point where we want it before inserting the forwarded
;; message.
- (if message-forward-before-signature
- (message-goto-body)
- (goto-char (point-max)))
- (if message-forward-as-mime
- (insert "\n\n<#part type=message/rfc822 disposition=inline>\n")
- (insert "\n-------------------- Start of forwarded message --------------------\n"))
- (let ((b (point))
- e)
- (mml-insert-buffer cur)
- (setq e (point))
- (if message-forward-as-mime
- (insert "<#/part>\n")
- (insert "\n-------------------- End of forwarded message --------------------\n"))
- (when (and (not current-prefix-arg)
- message-forward-ignored-headers)
- (save-restriction
- (narrow-to-region b e)
- (goto-char b)
- (narrow-to-region (point) (or (search-forward "\n\n" nil t) (point)))
- (message-remove-header message-forward-ignored-headers t))))
+ (if message-signature-before-forwarded-message
+ (goto-char (point-max))
+ (message-goto-body))
+ ;; Make sure we're at the start of the line.
+ (unless (eolp)
+ (insert "\n"))
+ ;; Narrow to the area we are to insert.
+ (narrow-to-region (point) (point))
+ ;; Insert the separators and the forwarded buffer.
+ (insert message-forward-start-separator)
+ (setq art-beg (point))
+ (insert-buffer-substring cur)
+ (goto-char (point-max))
+ (insert message-forward-end-separator)
+ (set-text-properties (point-min) (point-max) nil)
+ ;; Remove all unwanted headers.
+ (goto-char art-beg)
+ (narrow-to-region (point) (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (point)))
+ (goto-char (point-min))
+ (message-remove-header message-included-forward-headers t nil t)
+ (widen)
(message-position-point)))
;;;###autoload
(defun message-resend (address)
"Resend the current article to ADDRESS."
- (interactive
- (list (message-read-from-minibuffer "Resend message to: ")))
+ (interactive "sResend message to: ")
(message "Resending message to %s..." address)
(save-excursion
(let ((cur (current-buffer))
beg)
;; We first set up a normal mail buffer.
(set-buffer (get-buffer-create " *message resend*"))
+ (buffer-disable-undo (current-buffer))
(erase-buffer)
- (message-setup `((To . ,address)))
+ ;; avoid to turn-on-mime-edit
+ (let (message-setup-hook)
+ (message-setup `((To . ,address)))
+ )
;; Insert our usual headers.
(message-generate-headers '(From Date To))
(message-narrow-to-headers)
(when (looking-at "From ")
(replace-match "X-From-Line: "))
;; Send it.
- (let ((message-inhibit-body-encoding t)
- message-required-mail-headers)
+ (let ((message-encoding-buffer (current-buffer))
+ (message-edit-buffer (current-buffer)))
(message-send-mail))
(kill-buffer (current-buffer)))
(message "Resending message to %s...done" address)))
+(defun message-bounce-setup-for-mime-edit ()
+ (set (make-local-variable 'message-setup-hook) nil)
+ (mime-edit-again))
+
;;;###autoload
(defun message-bounce ()
"Re-mail the current message.
contains some mail you have written which has been bounced back to
you."
(interactive)
- (let ((handles (mm-dissect-buffer t))
+ (let ((cur (current-buffer))
boundary)
(message-pop-to-buffer (message-buffer-name "bounce"))
- (if (stringp (car handles))
- ;; This is a MIME bounce.
- (mm-insert-part (car (last handles)))
- ;; This is a non-MIME bounce, so we try to remove things
- ;; manually.
- (mm-insert-part handles)
- (undo-boundary)
- (goto-char (point-min))
- (search-forward "\n\n" nil t)
- (or (and (re-search-forward message-unsent-separator nil t)
- (forward-line 1))
- (re-search-forward "^Return-Path:.*\n" nil t))
- ;; We remove everything before the bounced mail.
- (delete-region
- (point-min)
- (if (re-search-forward "^[^ \n\t]+:" nil t)
- (match-beginning 0)
- (point))))
+ (insert-buffer-substring cur)
+ (undo-boundary)
+ (message-narrow-to-head)
+ (if (and (message-fetch-field "MIME-Version")
+ (setq boundary (message-fetch-field "Content-Type")))
+ (if (string-match "boundary=\"\\([^\"]+\\)\"" boundary)
+ (setq boundary (concat (match-string 1 boundary) " *\n"
+ "Content-Type: message/rfc822"))
+ (setq boundary nil)))
+ (widen)
+ (goto-char (point-min))
+ (search-forward "\n\n" nil t)
+ (or (and boundary
+ (re-search-forward boundary nil t)
+ (forward-line 2))
+ (and (re-search-forward message-unsent-separator nil t)
+ (forward-line 1))
+ (re-search-forward "^Return-Path:.*\n" nil t))
+ ;; We remove everything before the bounced mail.
+ (delete-region
+ (point-min)
+ (if (re-search-forward "^[^ \n\t]+:" nil t)
+ (match-beginning 0)
+ (point)))
(save-restriction
(message-narrow-to-head)
(message-remove-header message-ignored-bounced-headers t)
(goto-char (point-max))
(insert mail-header-separator))
+ (when message-bounce-setup-function
+ (funcall message-bounce-setup-function))
+ (run-hooks 'message-bounce-setup-hook)
(message-position-point)))
;;;
(goto-char (min start end))
(while (< (point) end1)
(or (looking-at "[_\^@- ]")
- (insert (char-after) "\b"))
+ (insert (following-char) "\b"))
(forward-char 1)))))
;;;###autoload
(move-marker end1 (max start end))
(goto-char (min start end))
(while (re-search-forward "\b" end1 t)
- (if (eq (char-after) (char-after (- (point) 2)))
+ (if (eq (following-char) (char-after (- (point) 2)))
(delete-char -2))))))
(defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
(message "No matching groups")
(save-selected-window
(pop-to-buffer "*Completions*")
- (buffer-disable-undo)
+ (buffer-disable-undo (current-buffer))
(let ((buffer-read-only nil))
(erase-buffer)
(let ((standard-output (current-buffer)))
(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 varstr)
+ (message-clone-locals oldbuf)
(current-buffer))))
-(defun message-clone-locals (buffer &optional varstr)
+(defun message-clone-locals (buffer)
"Clone the local variables from BUFFER to the current buffer."
(let ((locals (save-excursion
(set-buffer buffer)
(buffer-local-variables)))
- (regexp "^gnus\\|^nn\\|^message\\|^user-mail-address"))
+ (regexp "^\\(gnus\\|nn\\|message\\|user-\\(mail-address\\|full-name\\)\\)"))
(mapcar
(lambda (local)
(when (and (consp local)
(car local)
- (string-match regexp (symbol-name (car local)))
- (or (null varstr)
- (string-match varstr (symbol-name (car local)))))
+ (string-match regexp (symbol-name (car local))))
(ignore-errors
(set (make-local-variable (car local))
(cdr local)))))
locals)))
+;;; @ for MIME Edit mode
+;;;
+
+(defun message-maybe-setup-default-charset ()
+ (let ((charset
+ (and (boundp 'gnus-summary-buffer)
+ (buffer-live-p gnus-summary-buffer)
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ default-mime-charset))))
+ (if charset
+ (progn
+ (make-local-variable 'default-mime-charset)
+ (setq default-mime-charset charset)
+ ))))
+
+(defun message-maybe-encode ()
+ (when message-mime-mode
+ (run-hooks 'mime-edit-translate-hook)
+ (if (catch 'mime-edit-error
+ (save-excursion
+ (mime-edit-translate-body)
+ ))
+ (error "Translation error!")
+ )
+ (end-of-invisible)
+ (run-hooks 'mime-edit-exit-hook)
+ ))
+
+(defun message-mime-insert-article (&optional message)
+ (interactive)
+ (let ((message-cite-function 'mime-edit-inserted-message-filter)
+ (message-reply-buffer
+ (message-get-parameter-with-eval 'original-buffer))
+ (start (point)))
+ (message-yank-original nil)
+ ))
+
+(set-alist 'mime-edit-message-inserter-alist
+ 'message-mode (function message-mime-insert-article))
+
;;; Miscellaneous functions
;; stolen (and renamed) from nnheader.el
(setq idx (1+ idx)))
string))
-;;;
-;;; MIME functions
-;;;
-
-(defvar message-inhibit-body-encoding nil)
-
-(defun message-encode-message-body ()
- (unless message-inhibit-body-encoding
- (let ((mail-parse-charset (or mail-parse-charset
- message-default-charset))
- (case-fold-search t)
- lines content-type-p)
- (message-goto-body)
- (save-restriction
- (narrow-to-region (point) (point-max))
- (let ((new (mml-generate-mime)))
- (when new
- (delete-region (point-min) (point-max))
- (insert new)
- (goto-char (point-min))
- (if (eq (aref new 0) ?\n)
- (delete-char 1)
- (search-forward "\n\n")
- (setq lines (buffer-substring (point-min) (1- (point))))
- (delete-region (point-min) (point))))))
- (save-restriction
- (message-narrow-to-headers-or-head)
- (message-remove-header "Mime-Version")
- (goto-char (point-max))
- (insert "MIME-Version: 1.0\n")
- (when lines
- (insert lines))
- (setq content-type-p
- (re-search-backward "^Content-Type:" nil t)))
- (save-restriction
- (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.
- (unless content-type-p
- (goto-char (point-min))
- (re-search-forward "^MIME-Version:")
- (forward-line 1)
- (insert "Content-Type: text/plain; charset=us-ascii\n")))))
-
-(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)))
-
-(provide 'message)
+(defvar message-save-buffer " *encoding")
+(defun message-save-drafts ()
+ (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)))
(run-hooks 'message-load-hook)
-;; Local Variables:
-;; coding: iso-8859-1
-;; End:
+(provide 'message)
;;; message.el ends here
projects / elisp / gnus.git- / blobdiff