mcs-xm.el

   1 ;;; mcs-xm.el --- MIME charset implementation for XEmacs-mule
   2
   3 ;; Copyright (C) 1997,1998,1999 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Keywords: emulation, compatibility, Mule
   7
   8 ;; This file is part of APEL (A Portable Emacs Library).
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;    This module requires Emacs 20.0.93, XEmacs 20.3-b5 (with mule)
  28 ;;    or later.
  29
  30 ;;; Code:
  31
  32 (require 'mcs-20)
  33
  34
  35 (defun encode-mime-charset-region (start end charset &optional lbt)
  36   "Encode the text between START and END as MIME CHARSET."
  37   (let ((cs (mime-charset-to-coding-system charset lbt)))
  38     (if cs
  39         (encode-coding-region start end cs)
  40       )))
  41
  42
  43 (defcustom mime-charset-decoder-alist
  44   (let ((alist
  45          '((hz-gb-2312 . decode-mime-charset-region-for-hz)
  46            (t . decode-mime-charset-region-default))))
  47     (if (featurep 'utf-2000)
  48         alist
  49       (list*
  50        '(iso-2022-jp . decode-mime-charset-region-with-iso646-unification)
  51        '(iso-2022-jp-2 . decode-mime-charset-region-with-iso646-unification)
  52        alist)))
  53   "Alist MIME-charset vs. decoder function."
  54   :group 'i18n
  55   :type '(repeat (cons mime-charset function)))
  56
  57 (defsubst decode-mime-charset-region-default (start end charset lbt)
  58   (let ((cs (mime-charset-to-coding-system charset lbt)))
  59     (if cs
  60         (decode-coding-region start end cs)
  61       )))
  62
  63 (unless (featurep 'utf-2000)
  64   (defcustom mime-iso646-character-unification-alist
  65     (eval-when-compile
  66       (let (dest
  67             (i 33))
  68         (while (< i 92)
  69           (setq dest
  70                 (cons (cons (char-to-string (make-char 'latin-jisx0201 i))
  71                             (format "%c" i))
  72                       dest))
  73           (setq i (1+ i)))
  74         (setq i 93)
  75         (while (< i 126)
  76           (setq dest
  77                 (cons (cons (char-to-string (make-char 'latin-jisx0201 i))
  78                             (format "%c" i))
  79                       dest))
  80           (setq i (1+ i)))
  81         (nreverse dest)))
  82     "Alist unified string vs. canonical string."
  83     :group 'i18n
  84     :type '(repeat (cons string string)))
  85
  86   (defcustom mime-unified-character-face nil
  87     "*Face of unified character."
  88     :group 'i18n
  89     :type 'face)
  90
  91   (defcustom mime-character-unification-limit-size 2048
  92     "*Limit size to unify characters."
  93     :group 'i18n
  94     :type 'integer)
  95
  96   (defun decode-mime-charset-region-with-iso646-unification (start end charset
  97                                                                    lbt)
  98     (decode-mime-charset-region-default start end charset lbt)
  99     (if (<= (- end start) mime-character-unification-limit-size)
 100         (save-excursion
 101           (let ((rest mime-iso646-character-unification-alist))
 102             (while rest
 103               (let ((pair (car rest)))
 104                 (goto-char start)
 105                 (while (search-forward (car pair) end t)
 106                   (let ((str (cdr pair)))
 107                     (put-text-property 0 (length str)
 108                                        'face mime-unified-character-face str)
 109                     (replace-match str 'fixed-case 'literal)
 110                     )
 111                   ))
 112               (setq rest (cdr rest)))))
 113       ))
 114   )
 115
 116 (defun decode-mime-charset-region-for-hz (start end charset lbt)
 117   (if lbt
 118       (save-restriction
 119         (narrow-to-region start end)
 120         (decode-coding-region (point-min)(point-max)
 121                               (mime-charset-to-coding-system 'raw-text lbt))
 122         (decode-hz-region (point-min)(point-max)))
 123     (decode-hz-region start end)))
 124
 125 (defun decode-mime-charset-region (start end charset &optional lbt)
 126   "Decode the text between START and END as MIME CHARSET."
 127   (if (stringp charset)
 128       (setq charset (intern (downcase charset)))
 129     )
 130   (let ((func (cdr (or (assq charset mime-charset-decoder-alist)
 131                        (assq t mime-charset-decoder-alist)))))
 132     (funcall func start end charset lbt)))
 133
 134 (defsubst encode-mime-charset-string (string charset &optional lbt)
 135   "Encode the STRING as MIME CHARSET."
 136   (let ((cs (mime-charset-to-coding-system charset lbt)))
 137     (if cs
 138         (encode-coding-string string cs)
 139       string)))
 140
 141 ;; (defsubst decode-mime-charset-string (string charset)
 142 ;;   "Decode the STRING as MIME CHARSET."
 143 ;;   (let ((cs (mime-charset-to-coding-system charset)))
 144 ;;     (if cs
 145 ;;         (decode-coding-string string cs)
 146 ;;       string)))
 147 (defun decode-mime-charset-string (string charset &optional lbt)
 148   "Decode the STRING as MIME CHARSET."
 149   (with-temp-buffer
 150     (insert string)
 151     (decode-mime-charset-region (point-min)(point-max) charset lbt)
 152     (buffer-string)))
 153
 154
 155 (defvar charsets-mime-charset-alist
 156   '(((ascii)                                            . us-ascii)
 157     ((ascii latin-iso8859-1)                            . iso-8859-1)
 158     ((ascii latin-iso8859-2)                            . iso-8859-2)
 159     ((ascii latin-iso8859-3)                            . iso-8859-3)
 160     ((ascii latin-iso8859-4)                            . iso-8859-4)
 161     ((ascii cyrillic-iso8859-5)                         . iso-8859-5)
 162 ;;; ((ascii cyrillic-iso8859-5)                         . koi8-r)
 163     ((ascii arabic-iso8859-6)                           . iso-8859-6)
 164     ((ascii greek-iso8859-7)                            . iso-8859-7)
 165     ((ascii hebrew-iso8859-8)                           . iso-8859-8)
 166     ((ascii latin-iso8859-9)                            . iso-8859-9)
 167     ((ascii latin-jisx0201
 168             japanese-jisx0208-1978 japanese-jisx0208)   . iso-2022-jp)
 169     ((ascii latin-jisx0201
 170             katakana-jisx0201 japanese-jisx0208)        . shift_jis)
 171     ((ascii korean-ksc5601)                             . euc-kr)
 172     ((ascii chinese-gb2312)                             . gb2312)
 173     ((ascii chinese-big5-1 chinese-big5-2)              . big5)
 174     ((ascii thai-xtis)                                  . tis-620)
 175     ((ascii latin-iso8859-1 greek-iso8859-7
 176             latin-jisx0201 japanese-jisx0208-1978
 177             chinese-gb2312 japanese-jisx0208
 178             korean-ksc5601 japanese-jisx0212)           . iso-2022-jp-2)
 179     ;; ((ascii latin-iso8859-1 greek-iso8859-7
 180     ;;         latin-jisx0201 japanese-jisx0208-1978
 181     ;;         chinese-gb2312 japanese-jisx0208
 182     ;;         korean-ksc5601 japanese-jisx0212
 183     ;;         chinese-cns11643-1 chinese-cns11643-2)      . iso-2022-int-1)
 184     ))
 185
 186
 187 (defun coding-system-to-mime-charset (coding-system)
 188   "Convert CODING-SYSTEM to a MIME-charset.
 189 Return nil if corresponding MIME-charset is not found."
 190   (setq coding-system
 191         (coding-system-name (coding-system-base coding-system)))
 192   (or (car (rassq coding-system mime-charset-coding-system-alist))
 193       coding-system))
 194
 195 (defun mime-charset-list ()
 196   "Return a list of all existing MIME-charset."
 197   (let ((dest (mapcar (function car) mime-charset-coding-system-alist))
 198         (rest (coding-system-list))
 199         cs)
 200     (while rest
 201       (setq cs (coding-system-name (coding-system-base (car rest))))
 202       (or (rassq cs mime-charset-coding-system-alist)
 203           (memq cs dest)
 204           (setq dest (cons cs dest)))
 205       (setq rest (cdr rest)))
 206     dest))
 207
 208
 209 ;;; @ end
 210 ;;;
 211
 212 (provide 'mcs-xm)
 213
 214 ;;; mcs-xm.el ends here