;;; message.el --- composing mail and news messages
-;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc.
-;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: mail, news
;; This file is part of GNU Emacs.
(eval-when-compile (require 'cl))
(require 'mailheader)
-(condition-case nil
- (require 'rmail)
- (t (message "Ignore any errors about rmail from this file")))
(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)
(defgroup message '((user-mail-address custom-variable)
(user-full-name custom-variable))
:group 'message-headers)
(defcustom message-syntax-checks nil
- ;; Guess this one shouldn't be easy to customize...
- "Controls what syntax checks should not be performed on outgoing posts.
+ ; 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.
(defcustom message-required-news-headers
'(From Newsgroups Subject Date Message-ID
(optional . Organization) Lines
- (optional . X-Newsreader))
- "Headers to be generated or prompted for when posting an article.
+ (optional . User-Agent))
+ "*Headers to be generated or prompted for when posting an article.
RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
Message-ID. Organization, Lines, In-Reply-To, Expires, and
-X-Newsreader are optional. If don't you want message to insert some
+User-Agent are optional. If don't you want message to insert some
header, remove it from this list."
:group 'message-news
:group 'message-headers
(defcustom message-required-mail-headers
'(From Subject Date (optional . In-Reply-To) Message-ID Lines
- (optional . X-Mailer))
- "Headers to be generated or prompted for when mailing a message.
+ (optional . User-Agent))
+ "*Headers to be generated or prompted for when mailing a message.
RFC822 required that From, Date, To, Subject and Message-ID be
-included. Organization, Lines and X-Mailer are optional."
+included. Organization, Lines and User-Agent are optional."
:group 'message-mail
:group 'message-headers
:type '(repeat sexp))
:group 'message-headers
:type 'regexp)
-(defcustom message-ignored-mail-headers "^[GF]cc:\\|^Resent-Fcc:"
+(defcustom message-ignored-mail-headers "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:"
"*Regexp of headers to be removed unconditionally before mailing."
:group 'message-mail
:group 'message-headers
:type 'regexp)
-(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|X-Trace:\\|X-Complaints-To:\\|Return-Path:\\|^Supersedes:"
+(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:"
"*Header lines matching this regexp will be deleted before posting.
It's best to delete old Path and Date headers before posting to avoid
any confusion."
:group 'message-interface
:type 'regexp)
+(defcustom message-subject-re-regexp "^[ \t]*\\([Rr][Ee]:[ \t]*\\)*[ \t]*"
+ "*Regexp matching \"Re: \" in the subject line."
+ :group 'message-various
+ :type 'regexp)
+
;;;###autoload
(defcustom message-signature-separator "^-- *$"
"Regexp matching the signature separator."
:group 'message-various)
(defcustom message-elide-elipsis "\n[...]\n\n"
- "*The string which is inserted for elided text.")
+ "*The string which is inserted for elided text."
+ :type 'string
+ :group 'message-various)
(defcustom message-interactive nil
"Non-nil means when sending a message wait for and display errors.
:group 'message-mail
:type 'boolean)
-(defcustom message-generate-new-buffers t
- "*Non-nil means that a new message buffer will be created whenever `mail-setup' is called.
+(defcustom message-generate-new-buffers 'unique
+ "*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 "on" t)
+ (const :tag "unique" unique)
+ (const :tag "unsent" unsent)
(function fun)))
(defcustom message-kill-buffer-on-exit nil
:type 'file
:group 'message-headers)
-(defcustom message-autosave-directory
- (nnheader-concat message-directory "drafts/")
- "*Directory where Message autosaves buffers.
-If nil, Message won't autosave."
- :group 'message-buffers
- :type 'directory)
+(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.
+The subject generated by the previous function is passed into each
+successive function.
-(defcustom message-forward-start-separator
- "------- Start of forwarded message -------\n"
- "*Delimiter inserted before forwarded messages."
- :group 'message-forwarding
- :type 'string)
+The provided functions are:
-(defcustom message-forward-end-separator
- "------- End of forwarded message -------\n"
- "*Delimiter inserted after forwarded messages."
- :group 'message-forwarding
- :type 'string)
+* message-forward-subject-author-subject (Source of article (author or
+ 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-signature-before-forwarded-message t
- "*If non-nil, put the signature before any included forwarded message."
+(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-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-ignored-resent-headers "^Return-receipt"
+(defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:"
"*All headers that match this regexp will be deleted when resending a message."
:group 'message-interface
:type 'regexp)
The headers should be delimited by a line whose contents match the
variable `mail-header-separator'.
-Legal values include `message-send-mail-with-sendmail' (the default),
-`message-send-mail-with-mh' and `message-send-mail-with-qmail'."
+Valid values include `message-send-mail-with-sendmail' (the default),
+`message-send-mail-with-mh', `message-send-mail-with-qmail' and
+`smtpmail-send-it'."
: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 :tag "Other"))
:group 'message-sending
:group 'message-mail)
-;; 1997-09-29 by MORIOKA Tomohiko
-(defcustom message-send-news-function 'message-send-news-with-gnus
+(defcustom message-send-news-function 'message-send-news
"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'."
(defvar gnus-select-method)
(defcustom message-post-method
(cond ((and (boundp 'gnus-post-method)
+ (listp gnus-post-method)
gnus-post-method)
gnus-post-method)
((boundp 'gnus-select-method)
gnus-select-method)
(t '(nnspool "")))
- "Method used to post news."
+ "*Method used to post news.
+Note that when posting from inside Gnus, for instance, this
+variable isn't used."
:group 'message-news
:group 'message-sending
;; This should be the `gnus-select-method' widget, but that might
: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
:type 'hook)
(defcustom message-header-setup-hook nil
- "Hook called narrowed to the headers when setting up a message
-buffer."
+ "Hook called narrowed to the headers when setting up a message buffer."
:group 'message-various
:type 'hook)
;;;###autoload
(defcustom message-yank-prefix "> "
- "*Prefix inserted on the lines of yanked messages.
-nil means use indentation."
+ "*Prefix inserted on the lines of yanked messages."
:type 'string
:group 'message-insertion)
:type 'integer)
;;;###autoload
-(defcustom message-cite-function
- (if (and (boundp 'mail-citation-hook)
- mail-citation-hook)
- mail-citation-hook
- 'message-cite-original)
- "*Function for citing an original message."
+(defcustom message-cite-function 'message-cite-original
+ "*Function for citing an original message.
+Predefined functions include `message-cite-original' and
+`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)
(define-widget 'message-header-lines 'text
"All header lines must be LFD terminated."
+ :format "%t:%n%v"
:valid-regexp "^\\'"
:error "All header lines must be newline terminated")
;; 33 and 126, except colon)", i. e., any chars except ctl chars,
;; space, or colon.
'(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:"))
- "Set this non-nil if the system's mailer runs the header and body together.
+ "*Set this non-nil if the system's mailer runs the header and body together.
\(This problem exists on Sunos 4 when sendmail is run in remote mode.)
The value should be an expression to test whether the problem will
actually occur."
;; Ignore errors in case this is used in Emacs 19.
;; Don't use ignore-errors because this is copied into loaddefs.el.
;;;###autoload
-(condition-case nil
- (define-mail-user-agent 'message-user-agent
- 'message-mail 'message-send-and-exit
- 'message-kill-buffer 'message-send-hook)
- (error nil))
+(ignore-errors
+ (define-mail-user-agent 'message-user-agent
+ 'message-mail 'message-send-and-exit
+ 'message-kill-buffer 'message-send-hook))
(defvar message-mh-deletable-headers '(Message-ID Date Lines Sender)
"If non-nil, delete the deletable headers before feeding to mh.")
The default is `abbrev', which uses mailabbrev. nil switches
mail aliases off.")
+(defcustom message-auto-save-directory
+ (nnheader-concat message-directory "drafts/")
+ "*Directory where Message auto-saves buffers if Gnus isn't running.
+If nil, Message won't auto-save."
+ :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)
+
;;; 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 "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content)
(1 'message-header-name-face)
(2 'message-header-name-face))
- (,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
- 1 'message-separator-face)
+ ,@(if (and mail-header-separator
+ (not (equal mail-header-separator "")))
+ `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
+ 1 'message-separator-face))
+ nil)
(,(concat "^[ \t]*"
"\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
- "[>|}].*")
- (0 'message-cited-text-face))))
+ "[:>|}].*")
+ (0 'message-cited-text-face))
+ ("<#/?\\(multipart\\|part\\|external\\).*>"
+ (0 'message-mml-face))))
"Additional expressions to highlight in Message mode.")
+;; XEmacs does it like this. For Emacs, we have to set the
+;; `font-lock-defaults' buffer-local variable.
+(put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t))
+
(defvar message-face-alist
'((bold . bold-region)
(underline . underline-region)
:group 'message-various
:type 'hook)
+(defvar message-send-coding-system 'binary
+ "Coding system to encode outgoing mail.")
+
+(defvar message-draft-coding-system
+ (cond
+ ((not (fboundp 'coding-system-p)) nil)
+ ((coding-system-p 'emacs-mule) 'emacs-mule)
+ ((memq 'escape-quoted (mm-get-coding-system-list)) 'escape-quoted)
+ ((coding-system-p 'no-conversion) 'no-conversion)
+ (t nil))
+ "Coding system to compose mail.")
+
;;; Internal variables.
(defvar message-buffer-list nil)
(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)
(Lines)
(Expires)
(Message-ID)
- (References)
- (X-Mailer)
- (X-Newsreader))
+ (References . message-shorten-references)
+ (User-Agent))
"Alist used for formatting headers.")
(eval-and-compile
(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 'nndraft-request-expire-articles "nndraft")
+ (autoload 'gnus-open-server "gnus-int")
+ (autoload 'gnus-request-post "gnus-int")
+ (autoload 'gnus-alive-p "gnus-util")
+ (autoload 'rmail-output "rmail"))
\f
(not paren))))
(push (buffer-substring beg (point)) elems)
(setq beg (match-end 0)))
- ((= (following-char) ?\")
+ ((eq (char-after) ?\")
(setq quoted (not quoted)))
- ((and (= (following-char) ?\()
+ ((and (eq (char-after) ?\()
(not quoted))
(setq paren t))
- ((and (= (following-char) ?\))
+ ((and (eq (char-after) ?\))
(not quoted))
(setq paren nil))))
(nreverse elems)))))
(when (and (file-exists-p file)
(file-readable-p file)
(file-regular-p file))
- (nnheader-temp-write nil
+ (with-temp-buffer
(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 ((value (mail-fetch-field header nil (not not-all))))
+ (let* ((inhibit-point-motion-hooks t)
+ (value (mail-fetch-field header nil (not not-all))))
(when value
- (nnheader-replace-chars-in-string value ?\n ? ))))
+ (while (string-match "\n[\t ]+" value)
+ (setq value (replace-match " " t t value)))
+ ;; We remove all text props.delete-region
+ (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)))
(defun message-add-header (&rest headers)
"Add the HEADERS to the message header, skipping those already present."
(erase-buffer))
(set-buffer (get-buffer-create " *message work*"))
(kill-all-local-variables)
- (buffer-disable-undo (current-buffer))))
+ (mm-enable-multibyte)))
(defun message-functionp (form)
"Return non-nil if FORM is funcallable."
(defun message-strip-subject-re (subject)
"Remove \"Re:\" from subject lines."
- (if (string-match "^[Rr][Ee]: *" subject)
+ (if (string-match message-subject-re-regexp subject)
(substring subject (match-end 0))
subject))
If FIRST, only remove the first instance of the header.
Return the number of headers removed."
(goto-char (point-min))
- (let ((regexp (if is-regexp header (concat "^" header ":")))
+ (let ((regexp (if is-regexp header (concat "^" (regexp-quote header) ":")))
(number 0)
(case-fold-search t)
last)
(forward-line 1)
(if (re-search-forward "^[^ \t]" nil t)
(goto-char (match-beginning 0))
- (point-max))))
+ (goto-char (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."
+ "Narrow the buffer to the head of the message.
+Point is left at the beginning of the narrowed-to region."
(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."
- (or message-this-is-news
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (and (message-fetch-field "newsgroups")
- (not (message-fetch-field "posted-to")))))))
+ (and (not message-this-is-mail)
+ (or message-this-is-news
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (and (message-fetch-field "newsgroups")
+ (not (message-fetch-field "posted-to"))))))))
(defun message-mail-p ()
"Say whether the current buffer contains a mail message."
- (or message-this-is-mail
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (or (message-fetch-field "to")
- (message-fetch-field "cc")
- (message-fetch-field "bcc"))))))
+ (and (not message-this-is-news)
+ (or message-this-is-mail
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (or (message-fetch-field "to")
+ (message-fetch-field "cc")
+ (message-fetch-field "bcc")))))))
(defun message-next-header ()
"Go to the beginning of the next header."
(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 ()
(defvar message-mode-map nil)
(unless message-mode-map
- (setq message-mode-map (copy-keymap text-mode-map))
+ (setq message-mode-map (make-keymap))
+ (set-keymap-parent message-mode-map 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-y" 'message-yank-original)
(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-e" 'message-elide-region)
(define-key message-mode-map "\C-c\C-v" 'message-delete-not-region)
+ (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))
(easy-menu-define
["Caesar (rot13) Region" message-caesar-region (mark t)]
["Elide Region" message-elide-region (mark t)]
["Delete Outside Region" message-delete-not-region (mark t)]
+ ["Kill To Signature" message-kill-to-signature t]
["Newline and Reformat" message-newline-and-reformat t]
["Rename buffer" message-rename-buffer t]
["Spellcheck" ispell-message t]
+ ["Attach file as MIME" message-mime-attach-file t]
"----"
["Send Message" message-send-and-exit t]
- ["Abort Message" message-dont-send t]))
+ ["Abort Message" message-dont-send t]
+ ["Kill Message" message-kill-buffer t]))
(easy-menu-define
message-mode-field-menu message-mode-map ""
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-r message-caesar-buffer-body (rot13 the message body)."
+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 message-mime-attach-file (attach a file as MIME)."
(interactive)
(kill-all-local-variables)
- (make-local-variable 'message-reply-buffer)
- (setq message-reply-buffer nil)
- (make-local-variable 'message-send-actions)
- (make-local-variable 'message-exit-actions)
+ (set (make-local-variable '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 major-mode 'message-mode)
(setq mode-name "Message")
(setq buffer-offer-save t)
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults '(message-font-lock-keywords t))
(make-local-variable 'facemenu-add-face-function)
(make-local-variable 'facemenu-remove-face-function)
(setq facemenu-add-face-function
facemenu-remove-face-function t)
(make-local-variable 'paragraph-separate)
(make-local-variable 'paragraph-start)
+ ;; `-- ' precedes the signature. `-----' appears at the start of the
+ ;; lines that delimit forwarded messages.
+ ;; Lines containing just >= 3 dashes, perhaps after whitespace,
+ ;; are also sometimes used and should be separators.
(setq paragraph-start
(concat (regexp-quote mail-header-separator)
- "$\\|[ \t]*[-_][-_][-_]+$\\|"
- "-- $\\|"
- ;;!!! Uhm... shurely this can't be right.
- "[> " (regexp-quote message-yank-prefix) "]+$\\|"
- paragraph-start))
- (setq paragraph-separate
- (concat (regexp-quote mail-header-separator)
- "$\\|[ \t]*[-_][-_][-_]+$\\|"
- "-- $\\|"
- "[> " (regexp-quote message-yank-prefix) "]+$\\|"
- paragraph-separate))
+ "$\\|[ \t]*[a-z0-9A-Z]*>+[ \t]*$\\|[ \t]*$\\|"
+ "-- $\\|---+$\\|"
+ page-delimiter
+ ;;!!! Uhm... shurely this can't be right?
+ "[> " (regexp-quote message-yank-prefix) "]+$"))
+ (setq paragraph-separate paragraph-start)
(make-local-variable 'message-reply-headers)
(setq message-reply-headers nil)
(make-local-variable 'message-newsreader)
(make-local-variable 'message-mailer)
(make-local-variable 'message-post-method)
- (make-local-variable 'message-sent-message-via)
- (setq message-sent-message-via nil)
- (make-local-variable 'message-checksum)
- (setq message-checksum nil)
+ (set (make-local-variable 'message-sent-message-via) nil)
+ (set (make-local-variable 'message-checksum) nil)
+ (set (make-local-variable 'message-mime-part) 0)
;;(when (fboundp 'mail-hist-define-keys)
;; (mail-hist-define-keys))
(when (string-match "XEmacs\\|Lucid" emacs-version)
(when (eq message-mail-alias-type 'abbrev)
(if (fboundp 'mail-abbrevs-setup)
(mail-abbrevs-setup)
- (funcall (intern "mail-aliases-setup"))))
+ (mail-aliases-setup)))
(message-set-auto-save-file-name)
+ (unless (string-match "XEmacs" emacs-version)
+ (set (make-local-variable 'font-lock-defaults)
+ '(message-font-lock-keywords t)))
+ (make-local-variable 'adaptive-fill-regexp)
+ (setq adaptive-fill-regexp
+ (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|" adaptive-fill-regexp))
+ (unless (boundp 'adaptive-fill-first-line-regexp)
+ (setq adaptive-fill-first-line-regexp nil))
+ (make-local-variable 'adaptive-fill-first-line-regexp)
+ (setq adaptive-fill-first-line-regexp
+ (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|"
+ adaptive-fill-first-line-regexp))
+ (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))
- (search-forward (concat "\n" mail-header-separator "\n") nil t))
+ (or (search-forward (concat "\n" mail-header-separator "\n") nil t)
+ (search-forward "\n\n" nil t)))
+
+(defun message-goto-eoh ()
+ "Move point to the end of the headers."
+ (interactive)
+ (message-goto-body)
+ (forward-line -2))
(defun message-goto-signature ()
- "Move point to the beginning of the message signature."
+ "Move point to the beginning of the message signature.
+If there is no signature in the article, go to the end and
+return nil."
(interactive)
(goto-char (point-min))
(if (re-search-forward message-signature-separator nil t)
(forward-line 1)
- (goto-char (point-max))))
+ (goto-char (point-max))
+ nil))
\f
(let ((co (message-fetch-reply-field "mail-copies-to")))
(when (and (null force)
co
- (equal (downcase co) "never"))
+ (or (equal (downcase co) "never")
+ (equal (downcase co) "nobody")))
(error "The user has requested not to have copies sent via mail")))
(when (and (message-position-on-field "To")
(mail-fetch-field "to")
(interactive "r")
(save-excursion
(goto-char end)
- (delete-region (point) (progn (message-goto-signature)
- (forward-line -2)
- (point)))
+ (delete-region (point) (if (not (message-goto-signature))
+ (point)
+ (forward-line -2)
+ (point)))
(insert "\n")
(goto-char beg)
(delete-region beg (progn (message-goto-body)
(forward-line 2)
(point))))
- (message-goto-signature)
- (forward-line -2))
+ (when (message-goto-signature)
+ (forward-line -2)))
+
+(defun message-kill-to-signature ()
+ "Deletes all text up to the signature."
+ (interactive)
+ (let ((point (point)))
+ (message-goto-signature)
+ (unless (eobp)
+ (forward-line -2))
+ (kill-region point (point))
+ (unless (bolp)
+ (insert "\n"))))
(defun message-newline-and-reformat ()
"Insert four newlines, and then reformat if inside quoted text."
(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)
(or (bolp) (insert "\n")))))
(defun message-elide-region (b e)
- "Elide the text between point and mark. An ellipsis (from
-message-elide-elipsis) will be inserted where the text was killed."
+ "Elide the text between point and mark.
+An ellipsis (from `message-elide-elipsis') will be inserted where the
+text was killed."
(interactive "r")
(kill-region b e)
(unless (bolp)
;; 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)))
+ (when (< (char-after b) 255)
+ (subst-char-in-region
+ b (1+ b) (char-after b)
+ (aref message-caesar-translation-table (char-after b))))
(incf b))))
(defun message-make-caesar-translation-table (n)
(name-default (concat "*message* " mail-trimmed-to))
(name (if enter-string
(read-string "New buffer name: " name-default)
- name-default))
- (default-directory
- (file-name-as-directory message-autosave-directory)))
+ name-default)))
(rename-buffer name t)))))
(defun message-fill-yanked-message (&optional justifyp)
(unless (bolp)
(insert ?\n))
(unless modified
- (setq message-checksum (cons (message-checksum) (buffer-size)))))))
+ (setq message-checksum (message-checksum))))))
-(defun message-cite-original ()
+(defun message-cite-original-without-signature ()
"Cite function in the standard Message manner."
(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 end)
+ (when (re-search-backward message-signature-separator start t)
+ ;; Also peel off any blank lines before the signature.
+ (forward-line -1)
+ (while (looking-at "^[ \t]*$")
+ (forward-line -1))
+ (forward-line 1)
+ (delete-region (point) end))
(goto-char start)
(while functions
(funcall (pop functions)))
(insert "\n"))
(funcall message-citation-line-function))))
+(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)))
+ (when message-citation-line-function
+ (unless (bolp)
+ (insert "\n"))
+ (funcall message-citation-line-function)))))
+
(defun message-insert-citation-line ()
"Function that inserts a simple citation line."
(when message-reply-headers
(bury-buffer buf)
(when (eq buf (current-buffer))
(message-bury buf)))
- (message-do-actions actions))))
+ (message-do-actions actions)
+ t)))
(defun message-dont-send ()
"Don't send the message you have been editing."
(interactive)
+ (set-buffer-modified-p t)
+ (save-buffer)
(let ((actions message-postpone-actions))
(message-bury (current-buffer))
(message-do-actions actions)))
Otherwise any failure is reported in a message back to
the user from the mailer."
(interactive "P")
- ;; Disabled test.
- (when (if (and buffer-file-name
- nil)
- (y-or-n-p (format "Send buffer contents as %s message? "
- (if (message-mail-p)
- (if (message-news-p) "mail and news" "mail")
- "news")))
- (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))
- (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 (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 autosave.
- (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))))
+ ;; 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 (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))
+ (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)))
(defun message-send-via-mail (arg)
- "Send the current message via mail."
+ "Send the current message via mail."
(message-send-mail arg))
(defun message-send-via-news (arg)
"Send the current message via news."
- (message-send-news arg))
+ (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))
(defun message-fix-before-sending ()
"Do various things to make the message nice before sending it."
;; Make sure there's a newline at the end of the message.
(goto-char (point-max))
(unless (bolp)
- (insert "\n")))
+ (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")))))
(defun message-add-action (action &rest types)
"Add ACTION to be performed when doing an exit of type TYPES."
(let ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
(case-fold-search nil)
(news (message-news-p))
- (message-buffer (current-buffer)))
+ (mailbuf (current-buffer)))
+ (message-encode-message-body)
(save-restriction
(message-narrow-to-headers)
;; Insert some headers.
(let ((message-deletable-headers
(if news nil message-deletable-headers)))
(message-generate-headers message-required-mail-headers))
+ (let ((mail-parse-charset message-posting-charset))
+ (mail-encode-encoded-word-buffer))
;; Let the user do all of the above.
(run-hooks 'message-header-hook))
(unwind-protect
(set-buffer tembuf)
(erase-buffer)
;; Avoid copying text props.
- ;; (insert (format
- ;; "%s" (save-excursion
- ;; (set-buffer message-buffer)
- ;; (buffer-string))))
- ;; 1997-09-29 by MORIOKA Tomohiko
- ;; Don't avoid text properties.
- (insert-buffer message-buffer)
+ (insert (format
+ "%s" (save-excursion
+ (set-buffer mailbuf)
+ (buffer-string))))
;; Remove some headers.
(save-restriction
(message-narrow-to-headers)
(or (message-fetch-field "cc")
(message-fetch-field "to")))
(message-insert-courtesy-copy))
- ;; 1997-09-29 by MORIOKA Tomohiko
- (run-hooks 'message-encode-mail-hook)
(funcall message-send-mail-function))
(kill-buffer tembuf))
- (set-buffer message-buffer)
+ (set-buffer mailbuf)
(push 'mail message-sent-message-via)))
(defun message-send-mail-with-sendmail ()
(save-excursion
(set-buffer errbuf)
(erase-buffer))))
- (let ((default-directory "/"))
+ (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)
(run-hooks 'message-send-mail-hook)
;; send the message
(case
- (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)
+ (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))
;; qmail-inject doesn't say anything on it's stdout/stderr,
;; we have to look at the retval instead
(0 nil)
(method (if (message-functionp message-post-method)
(funcall message-post-method arg)
message-post-method))
- (message-buffer (current-buffer))
+ (messbuf (current-buffer))
(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)
- ;; Avoid copying text props.
- ;; (insert (format
- ;; "%s" (save-excursion
- ;; (set-buffer message-buffer)
- ;; (buffer-string))))
- ;; 1997-09-29 by MORIOKA Tomohiko
- ;; Don't avoid text properties.
- (insert-buffer message-buffer)
- ;; Remove some headers.
- (save-restriction
- (message-narrow-to-headers)
+ (if (not (message-check-news-body-syntax))
+ nil
+ (message-encode-message-body)
+ (save-restriction
+ (message-narrow-to-headers)
+ ;; Insert some headers.
+ (message-generate-headers message-required-news-headers)
+ (let ((mail-parse-charset message-posting-charset))
+ (mail-encode-encoded-word-buffer))
+ ;; 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))))
;; Remove some headers.
- (message-remove-header message-ignored-news-headers t))
- (goto-char (point-max))
- ;; require one newline at the end.
- (or (= (preceding-char) ?\n)
- (insert ?\n))
- ;; 1997-09-29 by MORIOKA Tomohiko
- (run-hooks 'message-encode-news-hook)
- (setq result (funcall message-send-news-function method)))
- (kill-buffer tembuf))
- (set-buffer message-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)
- ))
+ (save-restriction
+ (message-narrow-to-headers)
+ ;; Remove some headers.
+ (message-remove-header message-ignored-news-headers t))
+ (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)))))
;;;
;;; 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)
- (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.
- (message-check-news-body-syntax)))))
+ ;; We narrow to the headers and check them first.
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-check-news-header-syntax))))))
(defun message-check-news-header-syntax ()
(and
(let* ((case-fold-search t)
(message-id (message-fetch-field "message-id" t)))
(or (not message-id)
+ ;; Is there an @ in the ID?
(and (string-match "@" message-id)
- (string-match "@[^\\.]*\\." message-id))
+ ;; Is there a dot in the ID?
+ (string-match "@[^.]*\\." message-id)
+ ;; Does the ID end with a dot?
+ (not (string-match "\\.>" message-id)))
(y-or-n-p
(format "The Message-ID looks strange: \"%s\". Really post? "
message-id)))))
nil)
(t t))))))
-(defconst message-max-size 60000)
-
(defun message-check-news-body-syntax ()
(and
;; Check for long lines.
(y-or-n-p "Empty article. Really post? "))))
;; Check for control characters.
(message-check 'control-chars
- (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t)
+ (if (re-search-forward "[\000-\007\013\015-\032\034-\037\200-\237]" nil t)
(y-or-n-p
"The article contains control characters. Really post? ")
t))
(message-check 'new-text
(or
(not message-checksum)
- (not (and (eq (message-checksum) (car message-checksum))
- (eq (buffer-size) (cdr message-checksum))))
+ (not (eq (message-checksum) message-checksum))
(y-or-n-p
"It looks like no new text has been added. Really post? ")))
;; Check the length of the signature.
(message-check 'signature
(goto-char (point-max))
- (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)))))
+ (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-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)
- (following-char))))
+ (char-after))))
(forward-char 1)))
sum))
"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)
(save-restriction
(while (setq file (message-fetch-field "fcc"))
(push file list)
(message-remove-header "fcc" nil t)))
- (run-hooks 'message-before-do-fcc-hook)
(goto-char (point-min))
(re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
(replace-match "" t t)
"Append this article to Unix/babyl mail file.."
(if (and (file-readable-p filename)
(mail-file-babyl-p filename))
- (gnus-output-to-rmail filename t)
+ (rmail-output-to-rmail-file 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 ()
- "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-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)))))
(defun message-make-message-id ()
"Make a unique Message-ID."
(when from
(let ((stop-pos
(string-match " *at \\| *@ \\| *(\\| *<" from)))
- (concat (if stop-pos (substring from 0 stop-pos) 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)
;; 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))))
- ;; Return the date in the future in UT.
- (timezone-make-date-arpa-standard
- (current-time-string current) (current-time-zone current) '(0 "UT"))))
+ (message-make-date current)))
(defun message-make-path ()
"Return uucp path."
(To nil)
(Distribution (message-make-distribution))
(Lines (message-make-lines))
- (X-Newsreader message-newsreader)
- (X-Mailer (and (not (message-fetch-field "X-Newsreader"))
- message-mailer))
+ (User-Agent message-newsreader)
(Expires (message-make-expires))
(case-fold-search t)
header value elem)
(setq header (car elem)))
(setq header elem))
(when (or (not (re-search-forward
- (concat "^" (downcase (symbol-name header)) ":")
+ (concat "^"
+ (regexp-quote
+ (downcase
+ (if (stringp header)
+ header
+ (symbol-name header))))
+ ":")
nil t))
(progn
;; The header was found. We insert a space after the
;; colon, if there is none.
- (if (/= (following-char) ? ) (insert " ") (forward-char 1))
+ (if (/= (char-after) ? ) (insert " ") (forward-char 1))
;; Find out whether the header is empty...
(looking-at "[ \t]*$")))
;; So we find out what value we should insert.
(progn
;; This header didn't exist, so we insert it.
(goto-char (point-max))
- (insert (symbol-name header) ": " value "\n")
+ (insert (if (stringp header) header (symbol-name header))
+ ": " value "\n")
(forward-line -1))
;; The value of this header was empty, so we clear
;; totally and insert the new value.
(insert "Original-")
(beginning-of-line))
(when (or (message-news-p)
- (string-match "^[^@]@.+\\..+" secure-sender))
+ (string-match "@.+\\.." secure-sender))
(insert "Sender: " secure-sender "\n")))))))
(defun message-insert-courtesy-copy ()
(goto-char (point-min))
(while (not (eobp))
(skip-chars-forward "^,\"" (point-max))
- (if (or (= (following-char) ?,)
+ (if (or (eq (char-after) ?,)
(eobp))
(when (not quoted)
(if (and (> (current-column) 78)
(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-references (header references)
+ "Limit REFERENCES to be shorter than 988 characters."
+ (let ((max 988)
+ (cut 4)
+ refs)
+ (with-temp-buffer
+ (insert references)
+ (goto-char (point-min))
+ (while (re-search-forward "<[^>]+>" nil t)
+ (push (match-string 0) refs))
+ (setq refs (nreverse refs))
+ (while (> (length (mapconcat 'identity refs " ")) max)
+ (when (< (length refs) (1+ cut))
+ (decf cut))
+ (setcdr (nthcdr cut refs) (cddr (nthcdr cut refs)))))
+ (insert (capitalize (symbol-name header)) ": "
+ (mapconcat 'identity refs " ") "\n")))
+
(defun message-position-point ()
"Move point to where the user probably wants to find it."
(message-narrow-to-headers)
(search-backward ":" )
(widen)
(forward-char 1)
- (if (= (following-char) ? )
+ (if (eq (char-after) ? )
(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))
- ;; Generate a new buffer name The Message Way.
- (message-generate-new-buffers
+ ((eq message-generate-new-buffers 'unsent)
(generate-new-buffer-name
- (concat "*" type
+ (concat "*unsent " type
(if to
(concat " to "
(or (car (mail-extract-address-components to))
(not (y-or-n-p
"Message already being composed; erase? ")))
(error "Message being composed")))
- (set-buffer (pop-to-buffer name))))
- (erase-buffer)
- (message-mode))
+ (set-buffer (pop-to-buffer name)))
+ (erase-buffer)
+ (message-mode)))
(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 "\\`\\*" (buffer-name))
+ (when (string-match "\\`\\*\\(unsent \\)?" (buffer-name))
(rename-buffer
(concat "*sent " (substring (buffer-name) (match-end 0))) t)))
;; Push the current buffer onto the list.
(defun message-set-auto-save-file-name ()
"Associate the message buffer with a file in the drafts directory."
- (when message-autosave-directory
- (setq message-draft-article (nndraft-request-associate-buffer "drafts"))
- (clear-visited-file-modtime)))
+ (when message-auto-save-directory
+ (if (gnus-alive-p)
+ (setq message-draft-article
+ (nndraft-request-associate-buffer "drafts"))
+ (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)))
(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
;;;
(defun message-mail (&optional to subject
other-headers continue switch-function
yank-action send-actions)
- "Start editing a mail message to be sent."
+ "Start editing a mail message to be sent.
+OTHER-HEADERS is an alist of header/value pairs."
(interactive)
(let ((message-this-is-mail t))
(message-pop-to-buffer (message-buffer-name "mail" to))
(Subject . ,(or subject ""))))))
;;;###autoload
-(defun message-reply (&optional to-address wide ignore-reply-to)
+(defun message-reply (&optional to-address wide)
"Start editing a reply to the article in the current buffer."
(interactive)
(let ((cur (current-buffer))
to (message-fetch-field "to")
cc (message-fetch-field "cc")
mct (message-fetch-field "mail-copies-to")
- reply-to (unless ignore-reply-to (message-fetch-field "reply-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 "^[ \t]*[Rr][Ee]:[ \t]*" subject)
+ (when (string-match message-subject-re-regexp subject)
(setq subject (substring subject (match-end 0))))
(setq subject (concat "Re: " subject))
;; Handle special values of Mail-Copies-To.
(when mct
- (cond ((equal (downcase mct) "never")
+ (cond ((or (equal (downcase mct) "never")
+ (equal (downcase mct) "nobody"))
(setq never-mct t)
(setq mct nil))
- ((equal (downcase mct) "always")
+ ((or (equal (downcase mct) "always")
+ (equal (downcase mct) "poster"))
(setq mct (or reply-to from)))))
(unless follow-to
cur)))
;;;###autoload
-(defun message-wide-reply (&optional to-address ignore-reply-to)
+(defun message-wide-reply (&optional to-address)
"Make a \"wide\" reply to the message in the current buffer."
(interactive)
- (message-reply to-address t ignore-reply-to))
+ (message-reply to-address t))
;;;###autoload
(defun message-followup (&optional to-newsgroups)
(setq distribution nil))
;; Remove any (buggy) Re:'s that are present and make a
;; proper one.
- (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject)
+ (when (string-match message-subject-re-regexp subject)
(setq subject (substring subject (match-end 0))))
(setq subject (concat "Re: " subject))
(widen))
`((References . ,(concat (or references "") (and references " ")
(or message-id "")))))
,@(when (and mct
- (not (equal (downcase mct) "never")))
- (list (cons 'Cc (if (equal (downcase mct) "always")
+ (not (or (equal (downcase mct) "never")
+ (equal (downcase mct) "nobody"))))
+ (list (cons 'Cc (if (or (equal (downcase mct) "always")
+ (equal (downcase mct) "poster"))
(or reply-to from "")
mct)))))
(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)
+ (let (from newsgroups message-id distribution buf sender)
(save-excursion
;; Get header info. from original article.
(save-restriction
(message-narrow-to-head)
(setq from (message-fetch-field "from")
+ sender (message-fetch-field "sender")
newsgroups (message-fetch-field "newsgroups")
message-id (message-fetch-field "message-id" t)
distribution (message-fetch-field "distribution")))
;; Make sure that this article was written by the user.
- (unless (string-equal
- (downcase (cadr (mail-extract-address-components from)))
- (downcase (message-make-address)))
+ (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.
(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)
(message "Canceling your article...")
(if (let ((message-syntax-checks
'dont-check-for-anything-just-trust-me))
- (message-send-news))
+ (funcall message-send-news-function))
(message "Canceling your article...done"))
(kill-buffer buf)))))
This is done simply by taking the old article and adding a Supersedes
header line with the old Message-ID."
(interactive)
- (let ((cur (current-buffer)))
+ (let ((cur (current-buffer))
+ (sender (message-fetch-field "sender"))
+ (from (message-fetch-field "from")))
;; Check whether the user owns the article that is to be superseded.
- (unless (string-equal
- (downcase (cadr (mail-extract-address-components
- (message-fetch-field "from"))))
- (downcase (message-make-address)))
+ (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"))
;; Get a normal message buffer.
(message-pop-to-buffer (message-buffer-name "supersede"))
(insert-file-contents file-name nil)))
(t (error "message-recover cancelled")))))
+;;; Washing Subject:
+
+(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
+ (insert-string subject)
+ (goto-char (point-min))
+ ;; strip Re/Fwd stuff off the beginning
+ (while (re-search-forward
+ "\\([Rr][Ee]:\\|[Ff][Ww][Dd]\\(\\[[0-9]*\\]\\)?:\\|[Ff][Ww]:\\)" nil t)
+ (replace-match ""))
+
+ ;; and gnus-style forwards [foo@bar.com] subject
+ (goto-char (point-min))
+ (while (re-search-forward "\\[[^ \t]*\\(@\\|\\.\\)[^ \t]*\\]" nil t)
+ (replace-match ""))
+
+ ;; and off the end
+ (goto-char (point-max))
+ (while (re-search-backward "([Ff][Ww][Dd])" nil t)
+ (replace-match ""))
+
+ ;; and finally, any whitespace that was left-over
+ (goto-char (point-min))
+ (while (re-search-forward "^[ \t]+" nil t)
+ (replace-match ""))
+ (goto-char (point-max))
+ (while (re-search-backward "[ \t]+$" nil t)
+ (replace-match ""))
+
+ (buffer-string)))
+
;;; Forwarding messages.
+(defun message-forward-subject-author-subject (subject)
+ "Generate a subject for a forwarded message.
+The form is: [Source] Subject, where if the original message was mail,
+Source is the sender, and if the original message was news, Source is
+the list of newsgroups is was posted to."
+ (concat "["
+ (or (message-fetch-field
+ (if (message-news-p) "newsgroups" "from"))
+ "(nowhere)")
+ "] " subject))
+
+(defun message-forward-subject-fwd (subject)
+ "Generate a subject for a forwarded message.
+The form is: Fwd: Subject, where Subject is the original subject of
+the message."
+ (concat "Fwd: " subject))
+
(defun message-make-forward-subject ()
"Return a Subject header suitable for the message in the current buffer."
(save-excursion
(save-restriction
(current-buffer)
(message-narrow-to-head)
- (concat "[" (or (message-fetch-field
- (if (message-news-p) "newsgroups" "from"))
- "(nowhere)")
- "] " (or (message-fetch-field "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") ""))))
+ ;; Make sure funcs is a list.
+ (and funcs
+ (not (listp funcs))
+ (setq funcs (list funcs)))
+ ;; Apply funcs in order, passing subject generated by previous
+ ;; func to the next one.
+ (while funcs
+ (when (message-functionp (car funcs))
+ (setq subject (funcall (car funcs) subject)))
+ (setq funcs (cdr funcs)))
+ subject))))
;;;###autoload
(defun message-forward (&optional news)
(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-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-goto-body)
+ (insert "\n\n<#part type=message/rfc822 disposition=inline>\n")
+ (mml-insert-buffer cur)
+ (insert "<#/part>\n")
(message-position-point)))
;;;###autoload
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)))
;; Insert our usual headers.
(goto-char (point-max)))
(insert mail-header-separator)
;; Rename all old ("Also-")Resent headers.
- (while (re-search-backward "^\\(Also-\\)?Resent-" beg t)
+ (while (re-search-backward "^\\(Also-\\)*Resent-" beg t)
(beginning-of-line)
(insert "Also-"))
;; Quote any "From " lines at the beginning.
(when (looking-at "From ")
(replace-match "X-From-Line: "))
;; Send it.
- (message-send-mail)
+ (let (message-required-mail-headers)
+ (message-send-mail))
(kill-buffer (current-buffer)))
(message "Resending message to %s...done" address)))
(same-window-buffer-names nil)
(same-window-regexps nil))
(message-pop-to-buffer (message-buffer-name "mail" to)))
- (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))
+ (let ((message-this-is-mail t))
+ (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))))
;;;###autoload
(defun message-mail-other-frame (&optional to subject)
(same-window-buffer-names nil)
(same-window-regexps nil))
(message-pop-to-buffer (message-buffer-name "mail" to)))
- (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))
+ (let ((message-this-is-mail t))
+ (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))))
;;;###autoload
(defun message-news-other-window (&optional newsgroups subject)
(same-window-buffer-names nil)
(same-window-regexps nil))
(message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
- (message-setup `((Newsgroups . ,(or newsgroups ""))
- (Subject . ,(or subject "")))))
+ (let ((message-this-is-news t))
+ (message-setup `((Newsgroups . ,(or newsgroups ""))
+ (Subject . ,(or subject ""))))))
;;;###autoload
(defun message-news-other-frame (&optional newsgroups subject)
(same-window-buffer-names nil)
(same-window-regexps nil))
(message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
- (message-setup `((Newsgroups . ,(or newsgroups ""))
- (Subject . ,(or subject "")))))
+ (let ((message-this-is-news t))
+ (message-setup `((Newsgroups . ,(or newsgroups ""))
+ (Subject . ,(or subject ""))))))
;;; underline.el
(goto-char (min start end))
(while (< (point) end1)
(or (looking-at "[_\^@- ]")
- (insert (following-char) "\b"))
+ (insert (char-after) "\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 (following-char) (char-after (- (point) 2)))
+ (if (eq (char-after) (char-after (- (point) 2)))
(delete-char -2))))))
(defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
(defvar gnus-active-hashtb)
(defun message-expand-group ()
+ "Expand the group name under point."
(let* ((b (save-excursion
(save-restriction
(narrow-to-region
(point))
(skip-chars-backward "^, \t\n") (point))))
(completion-ignore-case t)
- (string (buffer-substring b (point)))
+ (string (buffer-substring b (progn (skip-chars-forward "^,\t\n ")
+ (point))))
(hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))
(completions (all-completions string hashtb))
- (cur (current-buffer))
comp)
(delete-region b (point))
(cond
(message "No matching groups")
(save-selected-window
(pop-to-buffer "*Completions*")
- (buffer-disable-undo (current-buffer))
+ (buffer-disable-undo)
(let ((buffer-read-only nil))
(erase-buffer)
(let ((standard-output (current-buffer)))
(setq idx (1+ idx)))
string))
-(run-hooks 'message-load-hook)
+;;;
+;;; MIME functions
+;;;
+
+(defvar messgage-inhibit-body-encoding nil)
+
+(defun message-encode-message-body ()
+ (unless messgage-inhibit-body-encoding
+ (let ((mail-parse-charset (or mail-parse-charset
+ message-default-charset
+ message-posting-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")))))
(provide 'message)
+(run-hooks 'message-load-hook)
+
;;; message.el ends here
projects / elisp / gnus.git- / blobdiff