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