;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
;; Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
;; Keiichi Suzuki <kei-suzu@mail.wbs.ne.jp>
+;; Tatsuya Ichikawa <t-ichi@po.shiojiri.ne.jp>
+;; Katsumi Yamaoka <yamaoka@jpl.org>
;; Keywords: mail, news, MIME
;; This file is part of GNU Emacs.
(require 'mailabbrev))
(require 'mime-edit)
+;; Avoid byte-compile warnings.
+(eval-when-compile
+ (require 'mail-parse)
+ (require 'mm-bodies)
+ (require 'mm-encode)
+ )
+
(defgroup message '((user-mail-address custom-variable)
(user-full-name custom-variable))
"Mail and news message composing."
(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."
The default is `abbrev', which uses mailabbrev. nil switches
mail aliases off.")
-(defcustom message-autosave-directory
+(defcustom message-auto-save-directory
(nnheader-concat message-directory "drafts/")
- "*Directory where Message autosaves buffers if Gnus isn't running.
-If nil, Message won't autosave."
+ "*Directory where Message auto-saves buffers if Gnus isn't running.
+If nil, Message won't auto-save."
:group 'message-buffers
:type 'directory)
(Lines)
(Expires)
(Message-ID)
- ;; (References . message-shorten-references)
(References . message-fill-header)
(User-Agent))
"Alist used for formatting headers.")
(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)))))
(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)))
+ value)))
(defun message-narrow-to-field ()
"Narrow the buffer to the header on the current line."
(defun message-fetch-reply-field (header)
"Fetch FIELD from the message we're replying to."
- (let ((buffer (if (functionp message-reply-buffer)
- (funcall message-reply-buffer)
- message-reply-buffer)))
+ (let ((buffer (message-get-reply-buffer)))
(when (and buffer
(buffer-name buffer))
(save-excursion
(1+ max)))))
(message-sort-headers-1))))
+(defun message-eval-parameter (parameter)
+ (condition-case ()
+ (if (symbolp parameter)
+ (if (functionp parameter)
+ (funcall parameter)
+ (eval parameter))
+ parameter)
+ (error nil)))
+
+(defun message-get-reply-buffer ()
+ (message-eval-parameter message-reply-buffer))
+
+(defun message-get-original-reply-buffer ()
+ (message-eval-parameter
+ (cdr (assq 'original-buffer message-parameter-alist))))
+
\f
;;;
(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 "\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
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)."
(interactive)
(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)
(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")
prefix, and don't delete any headers."
(interactive "P")
(let ((modified (buffer-modified-p))
- buffer)
- (when (and message-reply-buffer
+ (buffer (message-get-reply-buffer)))
+ (when (and buffer
message-cite-function)
- (setq buffer
- (if (functionp message-reply-buffer)
- (funcall message-reply-buffer)
- message-reply-buffer))
(delete-windows-on buffer t)
(insert-buffer buffer)
(funcall message-cite-function)
"Send the current message via news."
(message-send-news 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.
(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?")
+ (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)
(delete-region (match-end 0)(std11-field-end))
(insert (concat " " (message-make-message-id)))
))
- (interactive)
(funcall message-send-mail-function))))
(funcall message-send-mail-function))
(kill-buffer tembuf))
(let ((errbuf (if message-interactive
(generate-new-buffer " sendmail errors")
0))
- resend-addresses delimline)
+ resend-to-addresses delimline)
(let ((case-fold-search t))
(save-restriction
(message-narrow-to-headers)
- ;; XXX: We need to handle Resent-CC/Resent-BCC, too.
- (setq resend-addresses (message-fetch-field "resent-to")))
+ (setq resend-to-addresses (message-fetch-field "resent-to")))
;; Change header-delimiter to be what sendmail expects.
(goto-char (point-min))
(re-search-forward
;; We must not do that for a resend
;; because we would find the original addresses.
;; For a resend, include the specific addresses.
- (if resend-addresses
- (list resend-addresses)
+ (if resend-to-addresses
+ (list resend-to-addresses)
'("-t")))))
(when message-interactive
(save-excursion
"Pass the prepared message buffer to qmail-inject.
Refer to the documentation for the variable `message-send-mail-function'
to find out how to use this."
- ;; replace the header delimiter with a blank line.
+ ;; replace the header delimiter with a blank line
(goto-char (point-min))
(re-search-forward
(concat "^" (regexp-quote mail-header-separator) "\n"))
;;; 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)
(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))
(sign "+"))
(when (< zone 0)
(setq sign ""))
- ;; We do all of this because XEmacs doesn't have the %z spec.
- (concat (format-time-string
- "%d %b %Y %H:%M:%S " (or now (current-time)))
- (format "%s%02d%02d"
- sign (/ zone 3600)
- (% zone 3600)))))
+ (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-followup-subject (subject)
"Make a followup Subject."
(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.
(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 last
+ (if (and (> (current-column) 78)
+ last)
(save-excursion
(goto-char last)
(looking-at "[ \t]*")
(search-backward ":" )
(widen)
(forward-char 1)
- (if (= (following-char) ? )
+ (if (eq (char-after) ? )
(forward-char 1)
(insert " ")))
(t
(nconc message-buffer-list (list (current-buffer))))))
(defvar mc-modes-alist)
-(defvar gnus-message-get-reply-buffer)
(defun message-setup (headers &optional replybuffer actions)
(when (and (boundp 'mc-modes-alist)
(not (assq 'message-mode mc-modes-alist)))
(when actions
(setq message-send-actions actions))
(setq message-reply-buffer
- (if (and (boundp 'gnus-message-get-reply-buffer)
- gnus-message-get-reply-buffer)
- gnus-message-get-reply-buffer
- replybuffer))
+ (or (cdr (assq 'reply-buffer message-parameter-alist))
+ replybuffer))
(goto-char (point-min))
;; Insert all the headers.
(mail-header-format
(defun message-set-auto-save-file-name ()
"Associate the message buffer with a file in the drafts directory."
- (when message-autosave-directory
+ (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-autosave-directory))
+ message-auto-save-directory))
(setq buffer-auto-save-file-name (make-auto-save-file-name)))
(clear-visited-file-modtime)))
"Start editing a reply to the article in the current buffer."
(interactive)
(let ((cur (current-buffer))
+ from subject date to cc
+ references message-id follow-to
(inhibit-point-motion-hooks t)
- from date subject mct mft mrt
- never-mct to cc
- references message-id follow-to gnus-warning)
+ mct never-mct mft mrt gnus-warning)
(save-restriction
(message-narrow-to-head)
;; Allow customizations to have their say.
;; Handle special values of Mail-Copies-To.
(when mct
(cond
- ((and (equal (downcase mct) "never")
+ ((and (or (equal (downcase mct) "never")
+ (equal (downcase mct) "nobody"))
(or (not (eq message-use-mail-copies-to 'ask))
(message-y-or-n-p
(concat "Obey Mail-Copies-To: never? ") t "\
directs you not to send your response to the author.")))
(setq never-mct t)
(setq mct nil))
- ((and (equal (downcase mct) "always")
+ ((and (or (equal (downcase mct) "always")
+ (equal (downcase mct) "poster"))
(or (not (eq message-use-mail-copies-to 'ask))
(message-y-or-n-p
(concat "Obey Mail-Copies-To: always? ") t "\
(if wide to-address nil)))
(setq message-reply-headers
- (vector 0 subject from date message-id references 0 0 ""))
+ (make-full-mail-header-from-decoded-header
+ 0 subject from date message-id references 0 0 ""))
(message-setup
`((Subject . ,subject)
;;;###autoload
(defun message-followup (&optional to-newsgroups)
- "Follow up to the message in the current buffer."
+ "Follow up to the message in the current buffer.
+If TO-NEWSGROUPS, use that as the new Newsgroups line."
(interactive)
(let ((cur (current-buffer))
+ from subject date mct
+ references message-id follow-to
(inhibit-point-motion-hooks t)
- from date subject mct mft mrt
(message-this-is-news t)
- followup-to distribution newsgroups posted-to
- references message-id follow-to gnus-warning)
+ followup-to distribution newsgroups gnus-warning posted-to mft mrt)
(save-restriction
(message-narrow-to-head)
- ;; Allow customizations to have their say.
- ;; This is a followup.
(when (message-functionp message-followup-to-function)
(setq follow-to
(funcall message-followup-to-function)))
- ;; Find all relevant headers we need.
(setq from (message-fetch-field "from")
date (message-fetch-field "date" t)
subject (or (message-fetch-field "subject") "none")
;; Handle special values of Mail-Copies-To.
(when mct
(cond
- ((and (equal (downcase mct) "never")
+ ((and (or (equal (downcase mct) "never")
+ (equal (downcase mct) "nobody"))
(or (not (eq message-use-mail-copies-to 'ask))
(message-y-or-n-p
(concat "Obey Mail-Copies-To: never? ") t "\
`Mail-Copies-To: never'
directs you not to send your response to the author.")))
(setq mct nil))
- ((and (equal (downcase mct) "always")
+ ((and (or (equal (downcase mct) "always")
+ (equal (downcase mct) "poster"))
(or (not (eq message-use-mail-copies-to 'ask))
(message-y-or-n-p
(concat "Obey Mail-Copies-To: always? ") t "\
(message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
(setq message-reply-headers
- (vector 0 subject from date message-id references 0 0 ""))
+ (make-full-mail-header-from-decoded-header
+ 0 subject from date message-id references 0 0 ""))
(message-setup
`((Subject . ,subject)
(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)
;;; @ 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)
(run-hooks 'mime-edit-exit-hook)
))
-;;; XXX: currently broken; message-yank-original resets message-reply-buffer.
-(defun message-mime-insert-article (&optional message)
- (interactive)
+(defun message-mime-insert-article (&optional full-headers)
+ (interactive "P")
(let ((message-cite-function 'mime-edit-inserted-message-filter)
- (message-reply-buffer gnus-original-article-buffer)
- )
+ (message-reply-buffer (message-get-original-reply-buffer))
+ (start (point)))
(message-yank-original nil)
- ))
+ (save-excursion
+ (narrow-to-region (goto-char start)
+ (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (point-max)))
+ (goto-char (point-min))
+ (let ((message-included-forward-headers
+ (if full-headers "" message-included-forward-headers)))
+ (message-remove-header message-included-forward-headers t nil t))
+ (widen))))
(set-alist 'mime-edit-message-inserter-alist
'message-mode (function message-mime-insert-article))
(mm-insert-rfc822-headers charset encoding))
(mm-encode-body)))))))
+(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)
(provide 'message)
projects / elisp / gnus.git- / blobdiff