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         (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