X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=788824ca29a20c8cee1624beabacd02015a5f222;hb=8fca8e8ce5dee24e4355bcacc22a48b1c55dc07c;hp=cb02b3b32ed39339851befc23b92fc1463ba2a95;hpb=10c02ca82a5b2f6dbd5efff59b5a1e9e01becacb;p=elisp%2Fgnus.git- diff --git a/lisp/message.el b/lisp/message.el index cb02b3b..788824c 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -4,7 +4,10 @@ ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko ;; Shuhei KOBAYASHI -;; Keiichi Suzuki +;; Keiichi Suzuki +;; Tatsuya Ichikawa +;; Katsumi Yamaoka +;; Kiyokazu SUTO ;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -236,13 +239,19 @@ included. Organization, Lines and User-Agent are optional." :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 @@ -327,7 +336,7 @@ If t, use `message-user-organization-file'." :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) @@ -493,6 +502,12 @@ The function `message-bounce' runs this hook." :group 'message-various :type 'hook) +(defcustom message-supersede-setup-hook nil + "Normal hook, run each time a supersede message is initialized. +The function `message-supersede' runs this hook." + :group 'message-various + :type 'hook) + (defcustom message-mode-hook nil "Hook run in message mode buffers." :group 'message-various @@ -501,8 +516,8 @@ The function `message-bounce' runs this hook." (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 @@ -534,6 +549,12 @@ nil means use indentation." :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'." @@ -602,7 +623,6 @@ If stringp, use this; if non-nil, use no host name (user name only)." (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 @@ -643,6 +663,11 @@ articles." :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 @@ -916,9 +941,6 @@ The cdr of ech entry is a function for applying the face to a region.") (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) @@ -1050,7 +1072,7 @@ The cdr of ech entry is a function for applying the face to a region.") (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" @@ -1085,12 +1107,12 @@ The cdr of ech entry is a function for applying the face to a region.") (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))))) @@ -1823,6 +1845,28 @@ However, if `message-yank-prefix' is non-nil, insert that prefix on each line." (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. @@ -1833,14 +1877,45 @@ if `message-yank-prefix' is non-nil, insert that prefix on each line. 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) @@ -2148,11 +2223,56 @@ the user from the mailer." (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. @@ -2167,7 +2287,6 @@ the user from the mailer." (if (not (message-check-mail-syntax)) (progn (message "") - ;;(message "Posting not performed") nil) (unwind-protect (save-excursion @@ -2177,25 +2296,24 @@ the user from the mailer." ;; 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." @@ -2224,31 +2342,31 @@ the user from the mailer." (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) @@ -2273,28 +2391,28 @@ to find out how to use this." (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) @@ -2349,6 +2467,38 @@ to find out how to use this." (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) @@ -2372,10 +2522,7 @@ to find out how to use this." (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) @@ -2389,29 +2536,17 @@ to find out how to use this." (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) @@ -2771,8 +2906,8 @@ to find out how to use this." (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)) @@ -3185,7 +3320,9 @@ Headers already prepared in the buffer are not modified." (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. @@ -3294,7 +3431,7 @@ Headers already prepared in the buffer are not modified." (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) @@ -3366,7 +3503,7 @@ Headers already prepared in the buffer are not modified." (search-backward ":" ) (widen) (forward-char 1) - (if (= (following-char) ? ) + (if (eq (char-after) ? ) (forward-char 1) (insert " "))) (t @@ -3575,7 +3712,7 @@ OTHER-HEADERS is an alist of header/value pairs." 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. @@ -3598,6 +3735,12 @@ OTHER-HEADERS is an alist of header/value pairs." 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) @@ -3648,7 +3791,10 @@ OTHER-HEADERS is an alist of header/value pairs." (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 @@ -3842,6 +3988,10 @@ responses here are directed to other newsgroups.")) (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. @@ -3875,7 +4025,11 @@ header line with the old Message-ID." (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 () @@ -3953,14 +4107,14 @@ the message." (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)) @@ -4062,9 +4216,6 @@ Optional NEWS will use news to forward instead of mail." (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)) @@ -4187,7 +4338,7 @@ which specify the range to operate on." (goto-char (min start end)) (while (< (point) end1) (or (looking-at "[_\^@- ]") - (insert (following-char) "\b")) + (insert (char-after) "\b")) (forward-char 1))))) ;;;###autoload @@ -4201,7 +4352,7 @@ which specify the range to operate on." (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) @@ -4322,22 +4473,257 @@ regexp varstr." (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) @@ -4382,21 +4768,6 @@ regexp varstr." (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)