From: keiichi Date: Fri, 16 Apr 1999 06:29:10 +0000 (+0000) Subject: lisp/mess-lcl.el: New file. X-Git-Tag: nana-gnus-6_12_14~2 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=c6841ee10a3ce77563408b8ab57395b361381e1a;p=elisp%2Fgnus.git- lisp/mess-lcl.el: New file. lisp/message.el: Separate locale control to `mess-lcl.el'. --- diff --git a/lisp/mess-lcl.el b/lisp/mess-lcl.el new file mode 100644 index 0000000..87fddb1 --- /dev/null +++ b/lisp/mess-lcl.el @@ -0,0 +1,378 @@ +;;; mess-lcl.el --- Control message format with recipient's locale +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. + +;; Author: Keiichi Suzuki +;; Keywords: mail, news, MIME + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This module controls message format with recipient's locale. + +;;; Code: + +(eval-when-compile + (require 'cl) + ) + +(require 'message) + +(defgroup message-locale '((message-encode-function custom-variable)) + "Control message format with recipient." + :link '(custom-manual "(message)Top") + :group 'message) + +(defcustom message-locale-default nil + "Default locale for sending message." + :group 'message-locale + :type 'symbol) + +(defcustom message-locale-detect-for-mail nil + "*A function called to detect locale from recipient mail address." + :group 'message-locale + :type 'function) + +(defcustom message-locale-detect-for-news + 'message-locale-detect-with-newsgroup-alist + "*A function called to detect locale from newsgroup." + :group 'message-locale + :type 'function) + +(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-locale) + +(defvar message-locale-newsgroup-alist + '(("^fj\\." . fj) + )) + +(defvar message-locale-mail-address-alist nil) + +(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-locale) + +(defvar message-locale-mime-charsets-alist + '((fj . (us-ascii iso-2022-jp iso-2022-jp-2)) + (none . nil) + )) + +(defface message-illegal-charsets-face + '((((class color)) + (:foreground "black" :background "red")) + (t + (:bold t :underline t))) + "Face used for displaying illegal charset." + :group 'message-faces) + +(defface message-warning-charsets-face + '((((class color)) + (:foreground "black" :background "yellow")) + (t + (:bold t :underline t))) + "Face used for displaying illegal charset." + :group 'message-faces) + + +;;; Internal variable. +(defvar message-locale-args nil) + + +;;; +;;; Utility functions. +;;; +(defun message-set-charsets-face (charsets face &optional start end) + (or start (setq start (point-min))) + (or end (setq end (point-max))) + (goto-char start) + (when charsets + (let (top) + (while (< (point) end) + (if (memq (charset-after) charsets) + (let ((start (point))) + (unless top + (setq top (point))) + (forward-char 1) + (while (and (< (point) end) + (memq (charset-after) charsets)) + (forward-char 1)) + (put-text-property start (point) 'face face)) + (forward-char 1))) + top))) + +(defmacro message-locale-args (symbol) + `(cdr (assq (quote ,symbol) message-locale-args)) + ) + +(defmacro message-locale-args-set (symbol val) + `(setq message-locale-args + (put-alist (quote ,symbol) ,val message-locale-args)) + ) + +(defmacro message-locale-args-original (symbol) + `(or (message-locale-args ,symbol) ,symbol) + ) + +(defmacro message-locale-args-original-set (symbol) + `(message-locale-args-set ,symbol ,symbol) + ) + +;;; +;;; Call from message.el +;;; +(defun message-locale-maybe-encode () + "Control MIME encoding for message sending. + +If would you like to control MIME encoding with recipient's locale, +then set this function to `message-encode-function'." + (when message-mime-mode + ;; Inherit the buffer local variable `mime-edit-pgp-processing'. + (let ((pgp-processing (with-current-buffer message-edit-buffer + mime-edit-pgp-processing))) + (setq mime-edit-pgp-processing pgp-processing)) + (run-hooks 'mime-edit-translate-hook)) + (let ((locale-list (message-locale-detect))) + (when message-mime-mode + (let ((message-save-encoder message-save-encoder) + (default-mime-charset-detect-method-for-write + default-mime-charset-detect-method-for-write) + (charsets-mime-charset-alist charsets-mime-charset-alist) + message-locale-args) + (message-locale-setup-mime-charset locale-list) + (if (catch 'mime-edit-error + (save-excursion + (mime-edit-pgp-enclose-buffer) + (mime-edit-translate-body) + )) + (error "Translation error!") + )) + (end-of-invisible) + (run-hooks 'mime-edit-exit-hook) + ))) + +;;; +;;; Detect locale. +;;; +(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))) + ))))) + +(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) + )) + +(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) + )) + +;;; +;;; Control MIME charset with recipient's locale. +;;; +(defun message-locale-setup-mime-charset (locale-list) + (message-locale-args-original-set charsets-mime-charset-alist) + (message-locale-args-original-set + default-mime-charset-detect-method-for-write) + (setq default-mime-charset-detect-method-for-write + (or message-mime-charset-recover-function + default-mime-charset-detect-method-for-write) + message-save-encoder 'message-locale-mime-save-encoder) + (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)) + ))) + +;;; +;;; Recover MIME charset. +;;; +(defun message-mime-charset-recover-by-ask (type charsets &rest args) + (let ((default-charset + (let ((charsets-mime-charset-alist + (message-locale-args-original charsets-mime-charset-alist))) + (charsets-to-mime-charset charsets))) + charset) + (save-excursion + (save-restriction + (save-window-excursion + (when (eq type 'region) + (narrow-to-region (car args) (car (cdr args))) + (message-mime-highlight-illegal-chars charsets) + (pop-to-buffer (current-buffer) nil t) + (recenter 1)) + (if (setq charset + (funcall message-mime-charset-recover-ask-function + (upcase (symbol-name + (or default-charset + default-mime-charset-for-write))) + 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)) + +(defun message-mime-highlight-illegal-chars (charsets) + (when charsets-mime-charset-alist + (let* ((min 65535) + (delta-lists + (delq nil + (mapcar + (lambda (x) + (when (<= (length x) min) + x)) + (delq nil (mapcar + (lambda (x) + (setq x (delq nil + (mapcar + (lambda (y) + (unless (memq y (car x)) + y)) + charsets) + )) + (when (<= (length x) min) + (setq min (length x)) + x)) + charsets-mime-charset-alist))))) + top cs done rest errors warns list) + (while (setq top (pop delta-lists)) + (while (setq cs (pop top)) + (setq done nil + list delta-lists) + (when cs + (while (setq rest (pop list)) + (if (setq rest (memq cs rest)) + (setcar rest nil) + (push cs warns) + (setq done t))) + (unless done + (push cs errors))))) + (put-text-property (point-min) (point-max) 'face nil) + (if (setq top (message-set-charsets-face + errors + 'message-illegal-charsets-face)) + (message-set-charsets-face warns 'message-warning-charsets-face) + (setq top (message-set-charsets-face + warns 'message-warning-charsets-face))) + (if top + (goto-char top) + (goto-char (point-min)))))) + +;;; @ for MIME Edit mode +;;; +(defun message-locale-mime-save-encoder (orig-buf) + (when (with-current-buffer orig-buf mime-edit-mode-flag) + (let ((charsets-mime-charset-alist + (message-locale-args-original charsets-mime-charset-alist)) + (default-mime-charset-detect-method-for-write + (message-locale-args-original + default-mime-charset-detect-method-for-write))) + (mime-edit-translate-body) + (mime-edit-translate-header) + ))) + +(run-hooks 'mess-lcl-load-hook) + +(provide 'mess-lcl) + +;;; mess-lcl.el ends here diff --git a/lisp/message.el b/lisp/message.el index 3508694..ceaf1e2 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -136,10 +136,13 @@ mailbox format." (function :tag "Other")) :group 'message-sending) -(defcustom message-encode-function 'message-maybe-encode +(autoload 'message-locale-maybe-encode "mess-lcl") +(defcustom message-encode-function 'message-locale-maybe-encode "*A function called to encode messages." - :group 'message-sending - :type 'function) + :type '(radio (function-item message-locale-maybe-encode) + (function-item message-maybe-encode) + (function :tag "Other")) + :group 'message-sending) (defcustom message-8bit-encoding-list '(8bit binary) "*8bit encoding type in Content-Transfer-Encoding field." @@ -3663,6 +3666,8 @@ Headers already prepared in the buffer are not modified." (run-hooks 'message-header-setup-hook)) (set-buffer-modified-p nil) (setq buffer-undo-list nil) + (add-to-list 'buffer-file-format 'message) + (set-buffer-file-coding-system nnheader-message-coding-system-for-write) (run-hooks 'message-setup-hook) (message-position-point) (undo-boundary)) @@ -4542,300 +4547,50 @@ This variable is used by \`message-check-mailing-list-with-function\'." alist) )) -;;; @ for locale specification. +;;; @ Encode buffer. ;;; -(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) - -(defmacro message-mime-charset-recover-args-set (symbol) - `(cons (cons ,symbol (symbol-value ,symbol)) - message-mime-charset-recover-args)) - -(defmacro message-mime-charset-recover-args (symbol) - `(cdr (assq (quote ,symbol) message-mime-charset-recover-args)) - ) - -(defmacro message-mime-charset-recover-args-original (symbol) - `(or (message-mime-charset-recover-args ,symbol) ,symbol) - ) - (defun message-maybe-encode () (when message-mime-mode ;; Inherit the buffer local variable `mime-edit-pgp-processing'. (let ((pgp-processing (with-current-buffer message-edit-buffer mime-edit-pgp-processing))) (setq mime-edit-pgp-processing pgp-processing)) - (run-hooks 'mime-edit-translate-hook)) - (let ((locale-list (message-locale-detect))) - (when message-mime-mode - (let ((message-mime-charset-recover-args - (mapcar (lambda (symbol) (cons symbol (symbol-value symbol))) - '(default-mime-charset-detect-method-for-write - charsets-mime-charset-alist))) - (default-mime-charset-detect-method-for-write - (or message-mime-charset-recover-function - default-mime-charset-detect-method-for-write)) - (charsets-mime-charset-alist charsets-mime-charset-alist)) - (message-mime-charset-setup locale-list) - (if (catch 'mime-edit-error - (save-excursion - (mime-edit-pgp-enclose-buffer) - (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) + (run-hooks 'mime-edit-translate-hook) + (if (catch 'mime-edit-error + (save-excursion + (mime-edit-pgp-enclose-buffer) + (mime-edit-translate-body) + )) + (error "Translation error!") + )) + (end-of-invisible) + (run-hooks 'mime-edit-exit-hook) + ) -(defun message-mime-charset-recover-by-ask (type charsets &rest args) - (let ((default-charset - (let ((charsets-mime-charset-alist - (message-mime-charset-recover-args - charsets-mime-charset-alist))) - (charsets-to-mime-charset charsets))) - charset) - (save-excursion - (save-restriction - (save-window-excursion - (when (eq type 'region) - (narrow-to-region (car args) (car (cdr args))) - (message-highlight-illegal-chars charsets) - (pop-to-buffer (current-buffer) nil t) - (recenter 1)) - (if (setq charset - (funcall message-mime-charset-recover-ask-function - (upcase (symbol-name - (or default-charset - default-mime-charset-for-write))) - charsets)) - (intern (downcase charset)) - (error "Canceled."))))))) - -(defface message-illegal-charset-face - '((((class color)) - (:foreground "black" :background "red")) - (t - (:bold t :underline t))) - "Face used for displaying illegal charset." - :group 'message-faces) +;;; @ for saving buffer +;;; -(defface message-warning-charset-face - '((((class color)) - (:foreground "black" :background "yellow")) - (t - (:bold t :underline t))) - "Face used for displaying illegal charset." - :group 'message-faces) +(defvar message-save-encoder 'message-mime-save-encoder) -(defun message-highlight-illegal-chars (charsets) - (when charsets-mime-charset-alist - (let* ((min 65535) - (delta-lists - (delq nil - (mapcar - (lambda (x) - (when (<= (length x) min) - x)) - (delq nil (mapcar - (lambda (x) - (setq x (delq nil - (mapcar - (lambda (y) - (unless (memq y (car x)) - y)) - charsets) - )) - (when (<= (length x) min) - (setq min (length x)) - x)) - charsets-mime-charset-alist))))) - top cs done rest errors warns list) - (while (setq top (pop delta-lists)) - (while (setq cs (pop top)) - (setq done nil - list delta-lists) - (when cs - (while (setq rest (pop list)) - (if (setq rest (memq cs rest)) - (setcar rest nil) - (push cs warns) - (setq done t))) - (unless done - (push cs errors))))) - (put-text-property (point-min) (point-max) 'face nil) - (if (setq top (message-set-charsets-face - errors - 'message-illegal-charset-face)) - (message-set-charsets-face warns 'message-warning-charsets-face) - (setq top (message-set-charsets-face - warns 'message-warning-charset-face))) - (if top - (goto-char top) - (goto-char (point-min)))))) - -(defun message-set-charsets-face (charsets face &optional start end) - (or start - (setq start (point-min))) - (or end - (setq end (point-max))) - (goto-char start) - (when charsets - (let (top) - (while (< (point) end) - (if (memq (charset-after) charsets) - (let ((start (point))) - (unless top - (setq top (point))) - (forward-char 1) - (while (and (< (point) end) - (memq (charset-after) charsets)) - (forward-char 1)) - (put-text-property start (point) 'face face)) - (forward-char 1))) - top))) - -(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-save-formatter (start end &optional orig-buf) + "Format message, when save message buffer. [message.el]" + (save-restriction + (narrow-to-region start end) + (and message-save-encoder + (funcall message-save-encoder orig-buf)) + (goto-char start) + (and (search-forward (concat "\n" mail-header-separator "\n") nil t) + (replace-match "\n\n")) )) -(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)) - ))) +(set-alist 'format-alist + 'message + '("Message." + "1\\(^\\)" + nil + message-save-formatter + t nil)) ;;; @ for MIME Edit mode ;;; @@ -4859,44 +4614,21 @@ This funtion will by called from \`message-mime-charset-recover-by-ask\'." (set-alist 'mime-edit-message-inserter-alist 'message-mode (function message-mime-insert-article)) -(defun message-mime-encode (start end &optional orig-buf) - (let ((charsets-mime-charset-alist - (message-mime-charset-recover-args-original - charsets-mime-charset-alist)) - (default-mime-charset-detect-method-for-write - (message-mime-charset-recover-args-original - default-mime-charset-detect-method-for-write))) - (save-restriction - (narrow-to-region start end) - (when (with-current-buffer orig-buf - mime-edit-mode-flag) - (mime-edit-translate-body) - (mime-edit-translate-header) - )) - (goto-char start) - (and (search-forward (concat "\n" mail-header-separator "\n") nil t) - (replace-match "\n\n")) +(defun message-mime-save-encoder (orig-buf) + (when (with-current-buffer orig-buf mime-edit-mode-flag) + (mime-edit-translate-body) + (mime-edit-translate-header) )) -(set-alist 'format-alist - 'mime-message - '("MIME message." - "1\\(^\\)" - nil - message-mime-encode - t nil)) - -(defun message-after-save-hook () +(defun message-mime-after-save-hook () (set-buffer-file-coding-system nnheader-message-coding-system-for-write) (set-buffer-modified-p nil) ) (defun message-mime-setup () (turn-on-mime-edit) - (add-to-list 'buffer-file-format 'mime-message) - (set-buffer-file-coding-system nnheader-message-coding-system-for-write) (make-local-hook 'after-save-hook) - (add-hook 'after-save-hook 'message-after-save-hook nil t) + (add-hook 'after-save-hook 'message-mime-after-save-hook nil t) ) (run-hooks 'message-load-hook)