mcs-om.el

   1 ;;; mcs-om.el --- MIME charset implementation for Mule 1.* and Mule 2.*
   2
   3 ;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko
   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 ;;; Code:
  26
  27 (require 'poem)
  28
  29 (condition-case nil
  30     (require 'cyrillic)
  31   (error nil))
  32
  33 (defvar mime-charset-coding-system-alist
  34   '((iso-8859-1      . *ctext*)
  35     (x-ctext         . *ctext*)
  36     (gb2312          . *euc-china*)
  37     (koi8-r          . *koi8*)
  38     (iso-2022-jp-2   . *iso-2022-ss2-7*)
  39     (x-iso-2022-jp-2 . *iso-2022-ss2-7*)
  40     (shift_jis       . *sjis*)
  41     (x-shiftjis      . *sjis*)))
  42
  43 (defsubst mime-charset-to-coding-system (charset &optional lbt)
  44   "Return coding-system corresponding with CHARSET.
  45 CHARSET is a symbol whose name is MIME charset.
  46 If optional argument LBT (`CRLF', `LF', `CR', `unix', `dos' or `mac')
  47 is specified, it is used as line break code type of coding-system."
  48   (if (stringp charset)
  49       (setq charset (intern (downcase charset))))
  50   (setq charset (or (cdr (assq charset mime-charset-coding-system-alist))
  51                     (intern (concat "*" (symbol-name charset) "*"))))
  52   (if lbt
  53       (setq charset (intern (format "%s%s" charset
  54                                     (cond ((eq lbt 'CRLF) 'dos)
  55                                           ((eq lbt 'LF) 'unix)
  56                                           ((eq lbt 'CR) 'mac)
  57                                           (t lbt))))))
  58   (if (coding-system-p charset)
  59       charset))
  60
  61 (defsubst lbt-to-string (lbt)
  62   (cdr (assq lbt '((nil . nil)
  63                    (CRLF . "\r\n")
  64                    (CR . "\r")
  65                    (dos . "\r\n")
  66                    (mac . "\r")))))
  67
  68 (defun encode-mime-charset-region (start end charset &optional lbt)
  69   "Encode the text between START and END as MIME CHARSET."
  70   (let ((cs (mime-charset-to-coding-system charset lbt)))
  71     (if cs
  72         (code-convert start end *internal* cs)
  73       (if (and lbt (setq cs (mime-charset-to-coding-system charset)))
  74           (let ((newline (lbt-to-string lbt)))
  75             (save-excursion
  76               (save-restriction
  77                 (narrow-to-region start end)
  78                 (code-convert (point-min) (point-max) *internal* cs)
  79                 (if newline
  80                     (goto-char (point-min))
  81                   (while (search-forward "\n" nil t)
  82                     (replace-match newline))))))))))
  83
  84 (defun decode-mime-charset-region (start end charset &optional lbt)
  85   "Decode the text between START and END as MIME CHARSET."
  86   (let ((cs (mime-charset-to-coding-system charset lbt)))
  87     (if cs
  88         (code-convert start end cs *internal*)
  89       (if (and lbt (setq cs (mime-charset-to-coding-system charset)))
  90           (let ((newline (lbt-to-string lbt)))
  91             (if newline
  92                 (save-excursion
  93                   (save-restriction
  94                     (narrow-to-region start end)
  95                     (goto-char (point-min))
  96                     (while (search-forward newline nil t)
  97                       (replace-match "\n")))
  98                   (code-convert (point-min) (point-max) cs *internal*))
  99               (code-convert start end cs *internal*)))))))
 100
 101 (defun encode-mime-charset-string (string charset &optional lbt)
 102   "Encode the STRING as MIME CHARSET."
 103   (let ((cs (mime-charset-to-coding-system charset lbt)))
 104     (if cs
 105         (code-convert-string string *internal* cs)
 106       (if (and lbt (setq cs (mime-charset-to-coding-system charset)))
 107           (let ((newline (lbt-to-string lbt)))
 108             (if newline
 109                 (with-temp-buffer
 110                   (insert string)
 111                   (code-convert (point-min) (point-max) *internal* cs)
 112                   (goto-char (point-min))
 113                   (while (search-forward "\n" nil t)
 114                     (replace-match newline))
 115                   (buffer-string))
 116               (decode-coding-string string cs)))
 117         string))))
 118
 119 (defun decode-mime-charset-string (string charset &optional lbt)
 120   "Decode the STRING which is encoded in MIME CHARSET."
 121   (let ((cs (mime-charset-to-coding-system charset lbt)))
 122     (if cs
 123         (decode-coding-string string cs)
 124       (if (and lbt (setq cs (mime-charset-to-coding-system charset)))
 125           (let ((newline (lbt-to-string lbt)))
 126             (if newline
 127                 (with-temp-buffer
 128                   (insert string)
 129                   (goto-char (point-min))
 130                   (while (search-forward newline nil t)
 131                     (replace-match "\n"))
 132                   (code-convert (point-min) (point-max) cs *internal*)
 133                   (buffer-string))
 134               (decode-coding-string string cs)))
 135         string))))
 136
 137 (cond
 138  ((and (>= emacs-major-version 19) (>= emacs-minor-version 29))
 139   ;; for MULE 2.3 based on Emacs 19.34.
 140   (defun write-region-as-mime-charset (charset start end filename
 141                                                &optional append visit lockname)
 142     "Like `write-region', q.v., but code-convert by MIME CHARSET."
 143     (let ((file-coding-system
 144            (or (mime-charset-to-coding-system charset)
 145                *noconv*)))
 146       (write-region start end filename append visit lockname)))
 147   )
 148  (t
 149   ;; for MULE 2.3 based on Emacs 19.28.
 150   (defun write-region-as-mime-charset (charset start end filename
 151                                                &optional append visit lockname)
 152     "Like `write-region', q.v., but code-convert by MIME CHARSET."
 153     (let ((file-coding-system
 154            (or (mime-charset-to-coding-system charset)
 155                *noconv*)))
 156       (write-region start end filename append visit)))
 157   ))
 158
 159
 160 ;;; @ detection
 161 ;;;
 162
 163 (defvar charsets-mime-charset-alist
 164   (let ((alist
 165          '(((lc-ascii)                                  . us-ascii)
 166            ((lc-ascii lc-ltn1)                          . iso-8859-1)
 167            ((lc-ascii lc-ltn2)                          . iso-8859-2)
 168            ((lc-ascii lc-ltn3)                          . iso-8859-3)
 169            ((lc-ascii lc-ltn4)                          . iso-8859-4)
 170 ;;;        ((lc-ascii lc-crl)                           . iso-8859-5)
 171            ((lc-ascii lc-crl)                           . koi8-r)
 172            ((lc-ascii lc-arb)                           . iso-8859-6)
 173            ((lc-ascii lc-grk)                           . iso-8859-7)
 174            ((lc-ascii lc-hbw)                           . iso-8859-8)
 175            ((lc-ascii lc-ltn5)                          . iso-8859-9)
 176            ((lc-ascii lc-roman lc-jpold lc-jp)          . iso-2022-jp)
 177            ((lc-ascii lc-kr)                            . euc-kr)
 178            ((lc-ascii lc-cn)                            . gb2312)
 179            ((lc-ascii lc-big5-1 lc-big5-2)              . big5)
 180            ((lc-ascii lc-roman lc-ltn1 lc-grk
 181                       lc-jpold lc-cn lc-jp lc-kr
 182                       lc-jp2)                           . iso-2022-jp-2)
 183            ((lc-ascii lc-roman lc-ltn1 lc-grk
 184                       lc-jpold lc-cn lc-jp lc-kr lc-jp2
 185                       lc-cns1 lc-cns2)                  . iso-2022-int-1)
 186            ((lc-ascii lc-roman
 187                       lc-ltn1 lc-ltn2 lc-crl lc-grk
 188                       lc-jpold lc-cn lc-jp lc-kr lc-jp2
 189                       lc-cns1 lc-cns2 lc-cns3 lc-cns4
 190                       lc-cns5 lc-cns6 lc-cns7)          . iso-2022-int-1)
 191            ))
 192         dest)
 193     (while alist
 194       (catch 'not-found
 195         (let ((pair (car alist)))
 196           (setq dest
 197                 (append dest
 198                         (list
 199                          (cons (mapcar (function
 200                                         (lambda (cs)
 201                                           (if (boundp cs)
 202                                               (symbol-value cs)
 203                                             (throw 'not-found nil)
 204                                             )))
 205                                        (car pair))
 206                                (cdr pair)))))))
 207       (setq alist (cdr alist)))
 208     dest))
 209
 210 (defvar default-mime-charset 'x-ctext
 211   "Default value of MIME-charset.
 212 It is used when MIME-charset is not specified.
 213 It must be symbol.")
 214
 215 (defvar default-mime-charset-for-write
 216   default-mime-charset
 217   "Default value of MIME-charset for encoding.
 218 It is used when suitable MIME-charset is not found.
 219 It must be symbol.")
 220
 221 (defun detect-mime-charset-region (start end)
 222   "Return MIME charset for region between START and END."
 223   (or (charsets-to-mime-charset
 224        (cons lc-ascii (find-charset-region start end)))
 225       default-mime-charset-for-write))
 226
 227
 228 ;;; @ end
 229 ;;;
 230
 231 (require 'product)
 232 (product-provide (provide 'mcs-om) (require 'apel-ver))
 233
 234 ;;; mcs-om.el ends here