e99e6aa37574b306dfdc82213de9120665b6b70c
[elisp/gnus.git-] / lisp / mess-lcl.el
1 ;;; mess-lcl.el --- Control message format with recipient's locale
2 ;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3
4 ;; Author: Keiichi Suzuki   <keiichi@nanap.org>
5 ;; Keywords: mail, news, MIME
6
7 ;; This file is part of GNU Emacs.
8
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
12 ;; any later version.
13
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17 ;; GNU General Public License for more details.
18
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
23
24 ;;; Commentary:
25
26 ;; This module controls message format with recipient's locale.
27
28 ;;; Code:
29
30 (eval-when-compile
31   (require 'cl)
32   )
33
34 (require 'message)
35
36 (defgroup message-locale '((message-encode-function custom-variable))
37   "Control message format with recipient."
38   :link '(custom-manual "(message)Top")
39   :group 'message)
40
41 (defcustom message-locale-default nil
42   "Default locale for sending message."
43   :group 'message-locale
44   :type 'symbol)
45
46 (defcustom message-locale-detect-for-mail nil
47   "*A function called to detect locale from recipient mail address."
48   :group 'message-locale
49   :type 'function)
50
51 (defcustom message-locale-detect-for-news
52   'message-locale-detect-with-newsgroup-alist
53   "*A function called to detect locale from newsgroup."
54   :group 'message-locale
55   :type 'function)
56
57 (defcustom message-mime-charset-recover-function
58   'message-mime-charset-recover-by-ask
59   "A function called to recover \
60 when could not found legal MIME charset for sending message."
61   :type '(radio (function-item message-mime-charset-recover-by-ask)
62                 (function :tag "Other"))
63   :group 'message-locale)
64
65 (defvar message-locale-newsgroup-alist
66   '(("^fj\\." . fj)
67     ))
68
69 (defvar message-locale-mail-address-alist nil)
70
71 (defcustom message-mime-charset-recover-ask-function
72   'message-mime-charset-recover-ask-y-or-n
73   "A function called to ask MIME charset.
74 This funtion will by called from \`message-mime-charset-recover-by-ask\'."
75   :type '(radio (function-item message-mime-charset-recover-ask-y-or-n)
76                 (function-item message-mime-charset-recover-ask-charset)
77                 (function :tag "Other"))
78   :group 'message-locale)
79
80 (defvar message-locale-mime-charsets-alist
81   '((fj . (us-ascii iso-2022-jp iso-2022-jp-2))
82     (none . nil)
83     ))
84
85 (defface message-illegal-charsets-face
86   '((((class color))
87      (:foreground "black" :background "red"))
88     (t
89      (:bold t :underline t)))
90   "Face used for displaying illegal charset."
91   :group 'message-faces)
92
93 (defface message-warning-charsets-face
94   '((((class color))
95      (:foreground "black" :background "yellow"))
96     (t
97      (:bold t :underline t)))
98   "Face used for displaying illegal charset."
99   :group 'message-faces)
100
101
102 ;;; Internal variable.
103 (defvar message-locale-args nil)
104
105 \f
106 ;;;
107 ;;; Utility functions.
108 ;;;
109 (defun message-set-charsets-face (charsets face &optional start end)
110   (or start (setq start (point-min)))
111   (or end (setq end (point-max)))
112   (goto-char start)
113   (when charsets
114     (let (top)
115       (while (< (point) end)
116         (if (memq (charset-after) charsets)
117             (let ((start (point)))
118               (unless top
119                 (setq top (point)))
120               (forward-char 1)
121               (while (and (< (point) end)
122                           (memq (charset-after) charsets))
123                 (forward-char 1))
124               (put-text-property start (point) 'face face))
125           (forward-char 1)))
126       top)))
127
128 (defmacro message-locale-args (symbol)
129   `(cdr (assq (quote ,symbol) message-locale-args))
130   )
131
132 (defmacro message-locale-args-set (symbol val)
133   `(setq message-locale-args
134          (put-alist (quote ,symbol) ,val message-locale-args))
135   )
136
137 (defmacro message-locale-args-original (symbol)
138   `(or (message-locale-args ,symbol) ,symbol)
139   )
140
141 (defmacro message-locale-args-original-set (symbol)
142   `(message-locale-args-set ,symbol ,symbol)
143   )
144
145 ;;;
146 ;;; Call from message.el
147 ;;;
148 (defun message-locale-maybe-encode ()
149   "Control MIME encoding for message sending.
150
151 If would you like to control MIME encoding with recipient's locale,
152 then set this function to `message-encode-function'."
153   (when message-mime-mode
154     ;; Inherit the buffer local variable `mime-edit-pgp-processing'.
155     (let ((pgp-processing (with-current-buffer message-edit-buffer
156                             mime-edit-pgp-processing)))
157       (setq mime-edit-pgp-processing pgp-processing))
158     (run-hooks 'mime-edit-translate-hook))
159   (let ((locale-list (message-locale-detect)))
160     (when message-mime-mode
161       (let ((message-save-encoder message-save-encoder)
162             (default-mime-charset-detect-method-for-write
163               default-mime-charset-detect-method-for-write)
164             (charsets-mime-charset-alist charsets-mime-charset-alist)
165             message-locale-args)
166         (message-locale-setup-mime-charset locale-list)
167         (if (catch 'mime-edit-error
168               (save-excursion
169                 (mime-edit-pgp-enclose-buffer)
170                 (mime-edit-translate-body)
171                 ))
172             (error "Translation error!")
173           ))
174       (end-of-invisible)
175       (run-hooks 'mime-edit-exit-hook)
176       )))
177
178 ;;;
179 ;;; Detect locale.
180 ;;;
181 (defun message-locale-detect ()
182   (when (or message-locale-detect-for-news
183             message-locale-detect-for-mail)
184     (save-excursion
185       (save-restriction
186         (message-narrow-to-head)
187         (let (lc dest)
188           (when message-locale-detect-for-news
189             (setq lc (mapcar
190                       (lambda (newsgroup)
191                         (funcall message-locale-detect-for-news
192                                  (and (string-match "[^ \t]+" newsgroup)
193                                       (match-string 0 newsgroup))))
194                       (message-tokenize-header
195                        (message-fetch-field "newsgroups")))))
196           (when message-locale-detect-for-mail
197             (let ((field-list '("to" "cc" "bcc")))
198               (while (car field-list)
199                 (setq lc (append
200                           lc
201                           (mapcar
202                            (lambda (address)
203                              (funcall message-locale-detect-for-mail
204                                       (car
205                                        (cdr (std11-extract-address-components
206                                              address)))))
207                            (message-tokenize-header
208                             (message-fetch-field (pop field-list)))))))))
209           (setq lc (delq nil lc))
210           (while lc
211             (setq dest (cons (car lc) dest)
212                   lc (delq (car lc) lc)))
213           (or dest
214               (and message-locale-default (list message-locale-default)))
215           )))))
216
217 (defun message-locale-detect-with-newsgroup-alist (newsgroup)
218   (let ((rest message-locale-newsgroup-alist)
219         done)
220     (while (and (not done)
221                 rest)
222       (when (string-match (car (car rest)) newsgroup)
223         (setq done (car rest)))
224       (setq rest (cdr rest)))
225     (cdr done)
226     ))
227
228 (defun message-locale-detect-with-mail-address-alist (address)
229   (let ((rest message-locale-mail-address-alist)
230         done)
231     (while (and (not done)
232                 rest)
233       (when (string-match (car (car rest)) address)
234         (setq done (car rest)))
235       (setq rest (cdr rest)))
236     (cdr done)
237     ))
238
239 ;;;
240 ;;; Control MIME charset with recipient's locale.
241 ;;;
242 (defun message-locale-setup-mime-charset (locale-list)
243   (message-locale-args-original-set charsets-mime-charset-alist)
244   (message-locale-args-original-set
245    default-mime-charset-detect-method-for-write)
246   (setq default-mime-charset-detect-method-for-write
247         (or message-mime-charset-recover-function
248             default-mime-charset-detect-method-for-write)
249         message-save-encoder 'message-locale-mime-save-encoder)
250   (let (locale-cs)
251     (while (and charsets-mime-charset-alist
252                 locale-list)
253       (unless (setq locale-cs
254                     (assq (car locale-list)
255                           message-locale-mime-charsets-alist))
256         (error "Unknown locale \`%s\'. Add locale to \`%s\'."
257                (car locale-list)
258                'message-locale-mime-charsets-alist))
259       (setq locale-cs (cdr locale-cs)
260             charsets-mime-charset-alist (delq nil
261                                            (mapcar
262                                             (lambda (cs)
263                                               (and (memq (cdr cs) locale-cs)
264                                                    cs))
265                                             charsets-mime-charset-alist))
266             locale-list (cdr locale-list))
267       )))
268
269 ;;;
270 ;;; Recover MIME charset.
271 ;;;
272 (defun message-mime-charset-recover-by-ask (type charsets &rest args)
273   (let ((default-charset
274           (let ((charsets-mime-charset-alist
275                  (message-locale-args-original charsets-mime-charset-alist)))
276             (charsets-to-mime-charset charsets)))
277         charset)
278     (save-excursion
279       (save-restriction
280         (save-window-excursion
281           (when (eq type 'region)
282             (narrow-to-region (car args) (car (cdr args)))
283             (message-mime-highlight-illegal-chars charsets)
284             (pop-to-buffer (current-buffer) nil t)
285             (recenter 1))
286           (if (setq charset
287                     (funcall message-mime-charset-recover-ask-function
288                              (upcase (symbol-name
289                                       (or default-charset
290                                           default-mime-charset-for-write)))
291                              charsets))
292                    (intern (downcase charset))
293             (error "Canceled.")))))))
294
295 (defun message-mime-charset-recover-ask-y-or-n (default-charset charsets)
296   (or (y-or-n-p (format "MIME charset %s is selected. OK? "
297                         default-charset))
298       (error "Canceled."))
299   default-charset)
300
301 (defun message-mime-charset-recover-ask-charset (default-charset charsets)
302   (let ((alist (mapcar
303                 (lambda (cs)
304                   (list (upcase (symbol-name cs))))
305                 (mime-charset-list)))
306         charset)
307     (while (not charset)
308       (setq charset
309             (completing-read "What MIME charset: "
310                              alist nil t default-charset))
311       (when (string= charset "")
312         (setq charset nil)))
313     charset))
314
315 (defun message-mime-highlight-illegal-chars (charsets)
316   (when charsets-mime-charset-alist
317     (let* ((min 65535)
318            (delta-lists
319             (delq nil
320                   (mapcar
321                    (lambda (x)
322                      (when (<= (length x) min)
323                        x))
324                    (delq nil (mapcar
325                               (lambda (x)
326                                 (setq x (delq nil
327                                               (mapcar
328                                                (lambda (y)
329                                                  (unless (memq y (car x))
330                                                    y))
331                                                charsets)
332                                               ))
333                                 (when (<= (length x) min)
334                                   (setq min (length x))
335                                   x))
336                               charsets-mime-charset-alist)))))
337            top cs done rest errors warns list)
338       (while (setq top (pop delta-lists))
339         (while (setq cs (pop top))
340           (setq done nil
341                 list delta-lists)
342           (when cs
343             (while (setq rest (pop list))
344               (if (setq rest (memq cs rest))
345                   (setcar rest nil)
346                 (push cs warns)
347                 (setq done t)))
348             (unless done
349               (push cs errors)))))
350       (put-text-property (point-min) (point-max) 'face nil)
351       (if (setq top (message-set-charsets-face
352                      errors
353                      'message-illegal-charsets-face))
354           (message-set-charsets-face warns 'message-warning-charsets-face)
355         (setq top (message-set-charsets-face
356                    warns 'message-warning-charsets-face)))
357       (if top
358           (goto-char top)
359         (goto-char (point-min))))))
360
361 ;;; @ for MIME Edit mode
362 ;;;
363 (defun message-locale-mime-save-encoder (orig-buf)
364   (when (with-current-buffer orig-buf mime-edit-mode-flag)
365     (let ((charsets-mime-charset-alist
366            (message-locale-args-original charsets-mime-charset-alist))
367           (default-mime-charset-detect-method-for-write
368             (message-locale-args-original
369              default-mime-charset-detect-method-for-write)))
370       (mime-edit-translate-body)
371       (mime-edit-translate-header)
372       )))
373
374 (run-hooks 'mess-lcl-load-hook)
375
376 (provide 'mess-lcl)
377
378 ;;; mess-lcl.el ends here