git.chise.org Git - elisp/gnus.git-/blob - 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         (when (catch 'mime-edit-error
 168                 (save-excursion
 169                   (mime-edit-pgp-enclose-buffer)
 170                   (mime-edit-translate-body)))
 171           (error "Translation error!")))
 172       (end-of-invisible)
 173       (run-hooks 'mime-edit-exit-hook))))
 174
 175 ;;;
 176 ;;; Detect locale.
 177 ;;;
 178 (defun message-locale-detect ()
 179   (when (or message-locale-detect-for-news
 180             message-locale-detect-for-mail)
 181     (save-excursion
 182       (save-restriction
 183         (message-narrow-to-head)
 184         (let (lc dest)
 185           (when message-locale-detect-for-news
 186             (setq lc (mapcar
 187                       (lambda (newsgroup)
 188                         (funcall message-locale-detect-for-news
 189                                  (and (string-match "[^ \t]+" newsgroup)
 190                                       (match-string 0 newsgroup))))
 191                       (message-tokenize-header
 192                        (message-fetch-field "newsgroups")))))
 193           (when message-locale-detect-for-mail
 194             (let ((field-list '("to" "cc" "bcc")))
 195               (while (car field-list)
 196                 (setq lc (append
 197                           lc
 198                           (mapcar
 199                            (lambda (address)
 200                              (funcall message-locale-detect-for-mail
 201                                       (car
 202                                        (cdr (std11-extract-address-components
 203                                              address)))))
 204                            (message-tokenize-header
 205                             (message-fetch-field (pop field-list)))))))))
 206           (setq lc (delq nil lc))
 207           (while lc
 208             (setq dest (cons (car lc) dest)
 209                   lc (delq (car lc) lc)))
 210           (or dest
 211               (and message-locale-default (list message-locale-default)))
 212           )))))
 213
 214 (defun message-locale-detect-with-newsgroup-alist (newsgroup)
 215   (let ((rest message-locale-newsgroup-alist)
 216         done)
 217     (while (and (not done)
 218                 rest)
 219       (when (string-match (car (car rest)) newsgroup)
 220         (setq done (car rest)))
 221       (setq rest (cdr rest)))
 222     (cdr done)
 223     ))
 224
 225 (defun message-locale-detect-with-mail-address-alist (address)
 226   (let ((rest message-locale-mail-address-alist)
 227         done)
 228     (while (and (not done)
 229                 rest)
 230       (when (string-match (car (car rest)) address)
 231         (setq done (car rest)))
 232       (setq rest (cdr rest)))
 233     (cdr done)
 234     ))
 235
 236 ;;;
 237 ;;; Control MIME charset with recipient's locale.
 238 ;;;
 239 (defun message-locale-setup-mime-charset (locale-list)
 240   (message-locale-args-original-set charsets-mime-charset-alist)
 241   (message-locale-args-original-set
 242    default-mime-charset-detect-method-for-write)
 243   (setq default-mime-charset-detect-method-for-write
 244         (or message-mime-charset-recover-function
 245             default-mime-charset-detect-method-for-write)
 246         message-save-encoder 'message-locale-mime-save-encoder)
 247   (let (locale-cs)
 248     (while (and charsets-mime-charset-alist
 249                 locale-list)
 250       (unless (setq locale-cs
 251                     (assq (car locale-list)
 252                           message-locale-mime-charsets-alist))
 253         (error "Unknown locale \`%s\'. Add locale to \`%s\'."
 254                (car locale-list)
 255                'message-locale-mime-charsets-alist))
 256       (setq locale-cs (cdr locale-cs)
 257             charsets-mime-charset-alist (delq nil
 258                                            (mapcar
 259                                             (lambda (cs)
 260                                               (and (memq (cdr cs) locale-cs)
 261                                                    cs))
 262                                             charsets-mime-charset-alist))
 263             locale-list (cdr locale-list))
 264       )))
 265
 266 ;;;
 267 ;;; Recover MIME charset.
 268 ;;;
 269 (defun message-mime-charset-recover-by-ask (type charsets &rest args)
 270   (let ((default-charset
 271           (let ((charsets-mime-charset-alist
 272                  (message-locale-args-original charsets-mime-charset-alist)))
 273             (charsets-to-mime-charset charsets)))
 274         charset)
 275     (save-excursion
 276       (save-restriction
 277         (save-window-excursion
 278           (when (eq type 'region)
 279             (narrow-to-region (car args) (car (cdr args)))
 280             (message-mime-highlight-illegal-chars charsets)
 281             (pop-to-buffer (current-buffer) nil t)
 282             (recenter 1))
 283           (if (setq charset
 284                     (funcall message-mime-charset-recover-ask-function
 285                              (upcase (symbol-name
 286                                       (or default-charset
 287                                           default-mime-charset-for-write)))
 288                              charsets))
 289                    (intern (downcase charset))
 290             (throw 'message-sending-cancel t)))))))
 291
 292 (defun message-mime-charset-recover-ask-y-or-n (default-charset charsets)
 293   (and (y-or-n-p (format "MIME charset %s is selected. OK? "
 294                         default-charset))
 295        default-charset))
 296
 297 (defun message-mime-charset-recover-ask-charset (default-charset charsets)
 298   (let ((alist (mapcar
 299                 (lambda (cs)
 300                   (list (upcase (symbol-name cs))))
 301                 (mime-charset-list)))
 302         charset)
 303     (while (not charset)
 304       (setq charset
 305             (completing-read "What MIME charset: "
 306                              alist nil t default-charset))
 307       (when (string= charset "")
 308         (setq charset nil)))
 309     charset))
 310
 311 (defun message-mime-highlight-illegal-chars (charsets)
 312   (when charsets-mime-charset-alist
 313     (let* ((min 65535)
 314            (delta-lists
 315             (delq nil
 316                   (mapcar
 317                    (lambda (x)
 318                      (when (<= (length x) min)
 319                        x))
 320                    (delq nil (mapcar
 321                               (lambda (x)
 322                                 (setq x (delq nil
 323                                               (mapcar
 324                                                (lambda (y)
 325                                                  (unless (memq y (car x))
 326                                                    y))
 327                                                charsets)
 328                                               ))
 329                                 (when (<= (length x) min)
 330                                   (setq min (length x))
 331                                   x))
 332                               charsets-mime-charset-alist)))))
 333            top cs done rest errors warns list)
 334       (while (setq top (pop delta-lists))
 335         (while (setq cs (pop top))
 336           (setq done nil
 337                 list delta-lists)
 338           (when cs
 339             (while (setq rest (pop list))
 340               (if (setq rest (memq cs rest))
 341                   (setcar rest nil)
 342                 (push cs warns)
 343                 (setq done t)))
 344             (unless done
 345               (push cs errors)))))
 346       (put-text-property (point-min) (point-max) 'face nil)
 347       (if (setq top (message-set-charsets-face
 348                      errors
 349                      'message-illegal-charsets-face))
 350           (message-set-charsets-face warns 'message-warning-charsets-face)
 351         (setq top (message-set-charsets-face
 352                    warns 'message-warning-charsets-face)))
 353       (if top
 354           (goto-char top)
 355         (goto-char (point-min))))))
 356
 357 ;;; @ for MIME Edit mode
 358 ;;;
 359 (defun message-locale-mime-save-encoder (orig-buf)
 360   (when (with-current-buffer orig-buf mime-edit-mode-flag)
 361     (let ((charsets-mime-charset-alist
 362            (message-locale-args-original charsets-mime-charset-alist))
 363           (default-mime-charset-detect-method-for-write
 364             (message-locale-args-original
 365              default-mime-charset-detect-method-for-write)))
 366       (mime-edit-translate-body)
 367       (mime-edit-translate-header)
 368       )))
 369
 370 (run-hooks 'mess-lcl-load-hook)
 371
 372 (provide 'mess-lcl)
 373
 374 ;;; mess-lcl.el ends here