;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
;; Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
-;; Keiichi Suzuki <kei-suzu@mail.wbs.ne.jp>
+;; Keiichi Suzuki <kei-suzu@mail.wbs.ne.jp>
+;; Tatsuya Ichikawa <t-ichi@po.shiojiri.ne.jp>
+;; Katsumi Yamaoka <yamaoka@jpl.org>
+;; Kiyokazu SUTO <suto@merry.xmath.ous.ac.jp>
;; Keywords: mail, news, MIME
;; This file is part of GNU Emacs.
: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:\\|^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 '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-\\|^MIME-Version:"
+ "^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)
: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
(defcustom message-header-hook nil
"Hook run in a message mode before header encode. Buffer narrowed
to the headers."
- :group 'message-various
- :type 'hook)
+ :group 'message-various
+ :type 'hook)
(defcustom message-header-encode-function
'eword-encode-header
:type 'string
:group 'message-insertion)
+(defcustom message-yank-add-new-references t
+ "*Non-nil means new IDs will be added to \"References\" field when an
+article is yanked by the command `message-yank-original' interactively."
+ :type 'boolean
+ :group 'message-insertion)
+
(defcustom message-indentation-spaces 3
"*Number of spaces to insert at the beginning of each cited line.
Used by `message-yank-original' via `message-yank-cite'."
(defvar message-reply-buffer nil)
(defvar message-reply-headers nil)
-(defvar message-user-agent nil) ; XXX: This symbol is overloaded! See below.
(defvar message-sent-message-via nil)
(defvar message-checksum nil)
(defvar message-send-actions nil
:group 'message-news
:type 'message-header-lines)
+(defcustom message-mail-follow-up-address-checker nil
+ "A function of check follow up mail address."
+ :group 'message-mail
+ :type 'function)
+
;; Note: could use /usr/ucb/mail instead of sendmail;
;; options -t, and -v if not interactive.
(defcustom message-mailer-swallows-blank-line
(const :tag "always" t)
(const :tag "ask" ask)))
-(defvar message-send-coding-system 'binary
- "Coding system to encode outgoing mail.")
-
;;; Internal variables.
(defvar message-buffer-list nil)
(cdr (assq key alist)))
(defmacro message-get-parameter-with-eval (key &optional alist)
- `(message-eval-parameter (message-get-parameter ,alist ,key)))
+ `(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)))
- ((= (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)))))
(forward-line 1))))
(goto-char start)))
+(defun message-list-references (refs-list &rest refs-strs)
+ "Add `Message-ID's which appear in REFS-STRS but not in REFS-LIST,
+to REFS-LIST."
+ (let (refs ref id)
+ (while refs-strs
+ (setq refs (car refs-strs)
+ refs-strs (cdr refs-strs))
+ (when refs
+ (setq refs (std11-parse-msg-ids (std11-lexical-analyze refs)))
+ (while refs
+ (setq ref (car refs)
+ refs (cdr refs))
+ (when (eq (car ref) 'msg-id)
+ (setq id (concat "<"
+ (mapconcat
+ (function (lambda (p) (cdr p)))
+ (cdr ref) "")
+ ">"))
+ (or (member id refs-list)
+ (push id refs-list))))))
+ refs-list))
+
(defvar gnus-article-copy)
(defun message-yank-original (&optional arg)
"Insert the message being replied to, if any.
This function uses `message-cite-function' to do the actual citing.
Just \\[universal-argument] as argument means don't indent, insert no
-prefix, and don't delete any headers."
+prefix, and don't delete any headers.
+
+In addition, if `message-yank-add-new-references' is non-nil and this
+command is called interactively, new IDs from the yanked article will
+be added to \"References\" field."
(interactive "P")
(let ((modified (buffer-modified-p))
- (buffer (message-eval-parameter message-reply-buffer)))
+ (buffer (message-eval-parameter message-reply-buffer))
+ refs)
(when (and buffer
message-cite-function)
(delete-windows-on buffer t)
- (insert-buffer buffer)
+ (insert-buffer buffer) ; mark will be set at the end of article.
+
+ ;; Add new IDs to References field.
+ (when (and message-yank-add-new-references (interactive-p))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (point) (mark t))
+ (std11-narrow-to-header)
+ (when (setq refs (message-list-references
+ '()
+ (or (message-fetch-field "References")
+ (message-fetch-field "In-Reply-To"))
+ (message-fetch-field "Message-ID")))
+ (widen)
+ (message-narrow-to-headers)
+ (goto-char (point-min))
+ (let ((case-fold-search t))
+ (if (re-search-forward "^References:\\([\t ]+.+\n\\)+" nil t)
+ (replace-match "")
+ (goto-char (point-max))))
+ (mail-header-format
+ (list (or (assq 'References message-header-format-alist)
+ '(References . message-fill-references)))
+ (list (cons 'References
+ (mapconcat 'identity (nreverse refs) " "))))
+ (backward-delete-char 1)))))
+
(funcall message-cite-function)
(message-exchange-point-and-mark)
(unless (bolp)
(eval (car actions)))))
(pop actions)))
+(defsubst message-maybe-split-and-send-mail ()
+ "Split a message if necessary, and send it via mail.
+Returns nil if sending succeeded, returns any string if sending failed.
+This sub function is for exclusive use of `message-send-mail'."
+ (let ((mime-edit-split-ignored-field-regexp
+ mime-edit-split-ignored-field-regexp)
+ (case-fold-search t)
+ failure)
+ (while (string-match "Message-ID" mime-edit-split-ignored-field-regexp)
+ (setq mime-edit-split-ignored-field-regexp
+ (concat (substring mime-edit-split-ignored-field-regexp
+ 0 (match-beginning 0))
+ "Hey_MIME-Edit,_there_is_an_inviolable_Message_ID"
+ "_so_don't_rape_it!"
+ (substring mime-edit-split-ignored-field-regexp
+ (match-end 0)))))
+ (setq failure
+ (or
+ (catch 'message-sending-mail-failure
+ (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 " " (message-make-message-id))))
+ (condition-case err
+ (funcall message-send-mail-function)
+ (error
+ (throw 'message-sending-mail-failure err))))))
+ nil)
+ (condition-case err
+ (progn
+ (funcall message-send-mail-function)
+ nil)
+ (error err))))
+ (when failure
+ (if (eq 'error (car failure))
+ (cadr failure)
+ (prin1-to-string failure)))))
+
(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)))
+ (news (message-news-p))
+ failure)
(save-restriction
(message-narrow-to-headers)
;; Insert some headers.
(if (not (message-check-mail-syntax))
(progn
(message "")
- ;;(message "Posting not performed")
nil)
(unwind-protect
(save-excursion
;; Remove some headers.
(save-restriction
(message-narrow-to-headers)
+ ;; Remove some headers.
(message-remove-header message-ignored-mail-headers t))
(goto-char (point-max))
;; require one newline at the end.
- (or (= (preceding-char) ?\n)
+ (or (eq (char-before) ?\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))
+ (setq failure (message-maybe-split-and-send-mail)))
(kill-buffer tembuf))
(set-buffer message-edit-buffer)
- (push 'mail message-sent-message-via))))
+ (if failure
+ (progn
+ (message "Couldn't send message via mail: %s" failure)
+ nil)
+ (push 'mail message-sent-message-via)))))
(defun message-send-mail-with-sendmail ()
"Send off the prepared buffer with sendmail."
(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" (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")))))
+ (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)
(error "Sending failed; " result)))
(error "Sending failed; no recipients"))))
+(defsubst message-maybe-split-and-send-news (method)
+ "Split a message if necessary, and send it via news.
+Returns nil if sending succeeded, returns t if sending failed.
+This sub function is for exclusive use of `message-send-news'."
+ (let ((mime-edit-split-ignored-field-regexp
+ mime-edit-split-ignored-field-regexp)
+ (case-fold-search t))
+ (while (string-match "Message-ID" mime-edit-split-ignored-field-regexp)
+ (setq mime-edit-split-ignored-field-regexp
+ (concat (substring mime-edit-split-ignored-field-regexp
+ 0 (match-beginning 0))
+ "Hey_MIME-Edit,_there_is_an_inviolable_Message_ID"
+ "_so_don't_rape_it!"
+ (substring mime-edit-split-ignored-field-regexp
+ (match-end 0)))))
+ (or
+ (catch 'message-sending-news-failure
+ (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 " " (message-make-message-id))))
+ (unless (funcall message-send-news-function method)
+ (throw 'message-sending-news-failure t)))))
+ nil)
+ (not (funcall message-send-news-function method)))))
+
(defun message-send-news (&optional arg)
(let ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
(case-fold-search nil)
(run-hooks 'message-header-encoded-hook))
(message-cleanup-headers)
(if (not (message-check-news-syntax))
- (progn
- (message "")
- ;;(message "Posting not performed")
- nil)
+ nil
(unwind-protect
(save-excursion
(set-buffer tembuf)
(message-remove-header message-ignored-news-headers t))
(goto-char (point-max))
;; require one newline at the end.
- (or (= (preceding-char) ?\n)
+ (or (eq (char-before) ?\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)))
+ (setq result (message-maybe-split-and-send-news 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))))
+ (progn
+ (message "Couldn't send message via news: %s"
+ (nnheader-get-report (car method)))
+ nil)
+ (push 'news message-sent-message-via)))))
;; 1997-09-29 by MORIOKA Tomohiko
(defun message-send-news-with-gnus (method)
(concat "^" (regexp-quote mail-header-separator) "$"))
(while (not (eobp))
(when (not (looking-at "[ \t\n]"))
- (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1)
- (following-char))))
+ (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1)
+ (char-after))))
(forward-char 1)))
sum))
(progn
;; The header was found. We insert a space after the
;; colon, if there is none.
- (if (/= (following-char) ? ) (insert " ") (forward-char 1))
+ (if (eq (char-after) ? )
+ (forward-char 1)
+ (insert " "))
;; 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 (and (> (current-column) 78)
(search-backward ":" )
(widen)
(forward-char 1)
- (if (= (following-char) ? )
+ (if (eq (char-after) ? )
(forward-char 1)
(insert " ")))
(t
from subject date reply-to to cc
references message-id follow-to
(inhibit-point-motion-hooks t)
- mct never-mct gnus-warning)
+ mct never-mct gnus-warning in-reply-to)
(save-restriction
(message-narrow-to-head)
;; Allow customizations to have their say.
reply-to (message-fetch-field "reply-to")
references (message-fetch-field "references")
message-id (message-fetch-field "message-id" t))
+ ;; Get the references from "In-Reply-To" field if there were
+ ;; no references and "In-Reply-To" field looks promising.
+ (unless references
+ (when (and (setq in-reply-to (message-fetch-field "in-reply-to"))
+ (string-match "<[^>]+>" in-reply-to))
+ (setq references (match-string 0 in-reply-to))))
;; Remove any (buggy) Re:'s that are present and make a
;; proper one.
(when (string-match message-subject-re-regexp subject)
(message-tokenize-header (buffer-string))))
(let ((s ccalist))
(while s
- (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
+ (setq ccalist (delq (assoc (car (pop s)) s) ccalist))))
+ (when (functionp message-mail-follow-up-address-checker)
+ (setq ccalist (funcall message-mail-follow-up-address-checker
+ ccalist))))
(setq follow-to (list (cons 'To (cdr (pop ccalist)))))
(when ccalist
(let ((ccs (cons 'Cc (mapconcat
(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 ()
"Start composing a message to supersede the current message.
(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 ()
(current-buffer)
(message-narrow-to-head)
(let ((funcs message-make-forward-subject-function)
- (subject (if message-wash-forwarded-subjects
- (message-wash-subject
- (or (nnheader-decode-subject
- (message-fetch-field "Subject"))
- ""))
- (or (nnheader-decode-subject
- (message-fetch-field "Subject"))
- ""))))
+ (subject (message-fetch-field "Subject")))
+ (setq subject
+ (if subject
+ (if message-wash-forwarded-subjects
+ (message-wash-subject
+ (nnheader-decode-subject subject))
+ (nnheader-decode-subject subject))
+ "(none)"))
;; Make sure funcs is a list.
(and funcs
(not (listp funcs))
(message "Resending message to %s...done" address)))
(defun message-bounce-setup-for-mime-edit ()
- (goto-char (point-min))
- (when (search-forward (concat "\n" mail-header-separator "\n") nil t)
- (replace-match "\n\n"))
(set (make-local-variable 'message-setup-hook) nil)
(mime-edit-again))
(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)
(cdr local)))))
locals)))
-;;; @ for MIME Edit mode
+;; @ For `message-mail-follow-up-address-checker'.
+
+(defcustom message-mailing-list-address-list nil
+ "*Regexp matching addresses that are mailing lists.
+It must be a simple regexp string or a list of regexp strings.
+This variable is used by \`message-check-mailing-list-with-address-list\'."
+ :group 'message-mail
+ :type '(repeat regexp))
+
+(defun message-check-mailing-list-with-address-list (alist)
+ (let ((s alist)
+ (regexp (if (stringp message-mailing-list-address-list)
+ message-mailing-list-address-list
+ (mapconcat
+ (lambda (x)
+ x)
+ message-mailing-list-address-list
+ "\\|")))
+ address non-mailing-list mailing-list)
+ (while (setq address (car (pop s)))
+ (if (string-match regexp address)
+ (setq mailing-list t)
+ (setq non-mailing-list
+ (append non-mailing-list (list address)))))
+ (if (or (not non-mailing-list)
+ (not mailing-list)
+ (not (y-or-n-p "Do you want to remove private address? ")))
+ alist
+ (setq s non-mailing-list)
+ (while s
+ (setq alist (delq (assoc (pop s) alist) alist)))
+ alist)
+ ))
+
+(defcustom message-mailing-list-address-p nil
+ "*The function return t if address is a mailing list.
+It must be function, and interface is (ADDRESS).
+ADDRESS is a string of mail address.
+This variable is used by \`message-check-mailing-list-with-function\'."
+ :group 'message-mail
+ :type 'function)
+
+(defun message-check-mailing-list-with-function (alist)
+ (let ((s alist)
+ address non-mailing-list mailing-list)
+ (while (setq address (car (pop s)))
+ (if (funcall message-mailing-list-address-p address)
+ (setq mailing-list t)
+ (setq non-mailing-list
+ (append non-mailing-list (list address)))))
+ (if (or (not non-mailing-list)
+ (not mailing-list)
+ (not (y-or-n-p "Do you want to remove private address? ")))
+ alist
+ (setq s non-mailing-list)
+ (while s
+ (setq alist (delq (assoc (pop s) alist) alist)))
+ alist)
+ ))
+
+;;; @ for locale specification.
;;;
+(defcustom message-mime-charset-recover-function
+ 'message-mime-charset-recover-by-ask
+ "A function called to recover \
+when could not found legal MIME charset for sending message."
+ :type '(radio (function-item message-mime-charset-recover-by-ask)
+ (function :tag "Other"))
+ :group 'message-sending)
+
+(defvar message-mime-charset-recover-args nil)
+(defvar message-charsets-mime-charset-alist nil)
+
(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)
+ (run-hooks 'mime-edit-translate-hook))
+ (let ((locale-list (message-locale-detect)))
+ (when message-mime-mode
+ (let* ((default-mime-charset-detect-method-for-write
+ (or message-mime-charset-recover-function
+ default-mime-charset-detect-method-for-write))
+ message-mime-charset-recover-args
+ (charsets-mime-charset-alist charsets-mime-charset-alist)
+ (message-charsets-mime-charset-alist charsets-mime-charset-alist))
+ (message-mime-charset-setup locale-list)
+ (if (catch 'mime-edit-error
+ (save-excursion
+ (mime-edit-translate-body)
+ ))
+ (error "Translation error!")
+ ))
+ (end-of-invisible)
+ (run-hooks 'mime-edit-exit-hook)
+ )))
+
+(defcustom message-locale-default nil
+ "Default locale for sending message."
+ :group 'message-sending
+ :type 'symbol)
+
+(defcustom message-locale-detect-for-mail nil
+ "*A function called to detect locale from recipient mail address."
+ :group 'message-sending
+ :type 'function)
+
+(defcustom message-locale-detect-for-news
+ 'message-locale-detect-with-newsgroup-alist
+ "*A function called to detect locale from newsgroup."
+ :group 'message-sending
+ :type 'function)
+
+(defun message-locale-detect ()
+ (when (or message-locale-detect-for-news
+ message-locale-detect-for-mail)
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-head)
+ (let (lc dest)
+ (when message-locale-detect-for-news
+ (setq lc (mapcar
+ (lambda (newsgroup)
+ (funcall message-locale-detect-for-news
+ (and (string-match "[^ \t]+" newsgroup)
+ (match-string 0 newsgroup))))
+ (message-tokenize-header
+ (message-fetch-field "newsgroups")))))
+ (when message-locale-detect-for-mail
+ (let ((field-list '("to" "cc" "bcc")))
+ (while (car field-list)
+ (setq lc (append
+ lc
+ (mapcar
+ (lambda (address)
+ (funcall message-locale-detect-for-mail
+ (car
+ (cdr (std11-extract-address-components
+ address)))))
+ (message-tokenize-header
+ (message-fetch-field (pop field-list)))))))))
+ (setq lc (delq nil lc))
+ (while lc
+ (setq dest (cons (car lc) dest)
+ lc (delq (car lc) lc)))
+ (or dest
+ (and message-locale-default (list message-locale-default)))
+ )))))
+
+(defvar message-locale-newsgroup-alist
+ '(("^fj\\." . fj)
+ ))
+
+(defun message-locale-detect-with-newsgroup-alist (newsgroup)
+ (let ((rest message-locale-newsgroup-alist)
+ done)
+ (while (and (not done)
+ rest)
+ (when (string-match (car (car rest)) newsgroup)
+ (setq done (car rest)))
+ (setq rest (cdr rest)))
+ (cdr done)
+ ))
+
+(defvar message-locale-mail-address-alist nil)
+
+(defun message-locale-detect-with-mail-address-alist (address)
+ (let ((rest message-locale-mail-address-alist)
+ done)
+ (while (and (not done)
+ rest)
+ (when (string-match (car (car rest)) address)
+ (setq done (car rest)))
+ (setq rest (cdr rest)))
+ (cdr done)
+ ))
+
+(defcustom message-mime-charset-recover-ask-function
+ 'message-mime-charset-recover-ask-y-or-n
+ "A function called to ask MIME charset.
+This funtion will by called from \`message-mime-charset-recover-by-ask\'."
+ :type '(radio (function-item message-mime-charset-recover-ask-y-or-n)
+ (function-item message-mime-charset-recover-ask-charset)
+ (function :tag "Other"))
+ :group 'message-sending)
+
+(defun message-mime-charset-recover-by-ask (type charsets &rest args)
+ (let* ((charsets-mime-charset-alist message-charsets-mime-charset-alist)
+ (default-charset
+ (upcase (symbol-name
+ (or (charsets-to-mime-charset charsets)
+ default-mime-charset-for-write))))
+ charset)
+ (save-excursion
+ (save-restriction
+ (save-window-excursion
+ (when (eq type 'region)
+ (narrow-to-region (car args) (car (cdr args)))
+ (pop-to-buffer (current-buffer) nil t))
+ (if (setq charset (funcall message-mime-charset-recover-ask-function
+ default-charset charsets))
+ (intern (downcase charset))
+ (error "Canceled.")))))))
+
+(defun message-mime-charset-recover-ask-y-or-n (default-charset charsets)
+ (or (y-or-n-p (format "MIME charset %s is selected. OK? "
+ default-charset))
+ (error "Canceled."))
+ default-charset)
+
+(defun message-mime-charset-recover-ask-charset (default-charset charsets)
+ (let ((alist (mapcar
+ (lambda (cs)
+ (list (upcase (symbol-name cs))))
+ (mime-charset-list)))
+ charset)
+ (while (not charset)
+ (setq charset
+ (completing-read "What MIME charset: "
+ alist nil t default-charset))
+ (when (string= charset "")
+ (setq charset nil)))
+ charset))
+
+(defvar message-locale-mime-charsets-alist
+ '((fj . (us-ascii iso-2022-jp iso-2022-jp-2))
+ (none . nil)
))
+(defun message-mime-charset-setup (locale-list)
+ (let (locale-cs)
+ (while (and charsets-mime-charset-alist
+ locale-list)
+ (unless (setq locale-cs
+ (assq (car locale-list)
+ message-locale-mime-charsets-alist))
+ (error "Unknown locale \`%s\'. Add locale to \`%s\'."
+ (car locale-list)
+ 'message-locale-mime-charsets-alist))
+ (setq locale-cs (cdr locale-cs)
+ charsets-mime-charset-alist (delq nil
+ (mapcar
+ (lambda (cs)
+ (and (memq (cdr cs) locale-cs)
+ cs))
+ charsets-mime-charset-alist))
+ locale-list (cdr locale-list))
+ )))
+
+;;; @ for MIME Edit mode
+;;;
+
(defun message-mime-insert-article (&optional message)
(interactive)
(let ((message-cite-function 'mime-edit-inserted-message-filter)
(turn-on-mime-edit)
(add-to-list 'buffer-file-format 'mime-message))
-;;; Miscellaneous functions
-
-;; stolen (and renamed) from nnheader.el
-(defun message-replace-chars-in-string (string from to)
- "Replace characters in STRING from FROM to TO."
- (let ((string (substring string 0)) ;Copy string.
- (len (length string))
- (idx 0))
- ;; Replace all occurrences of FROM with TO.
- (while (< idx len)
- (when (= (aref string idx) from)
- (aset string idx to))
- (setq idx (1+ idx)))
- string))
-
(run-hooks 'message-load-hook)
(provide 'message)
projects / elisp / gnus.git- / blobdiff