git.chise.org Git - elisp/gnus.git-/blob - lisp/mm-util.el

   1 ;;; mm-util.el --- Utility functions for MIME things
   2 ;; Copyright (C) 1998 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; This file is part of GNU Emacs.
   7
   8 ;; GNU Emacs is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2, or (at your option)
  11 ;; any later version.
  12
  13 ;; GNU Emacs is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  21 ;; Boston, MA 02111-1307, USA.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (defvar mm-default-coding-system nil
  28   "The default coding system to use.")
  29
  30 (defvar mm-known-charsets '(iso-8859-1)
  31   "List of known charsets.")
  32
  33 (defvar mm-mime-mule-charset-alist
  34   '((us-ascii ascii)
  35     (iso-8859-1 latin-iso8859-1)
  36     (iso-8859-2 latin-iso8859-2)
  37     (iso-8859-3 latin-iso8859-3)
  38     (iso-8859-4 latin-iso8859-4)
  39     (iso-8859-5 cyrillic-iso8859-5)
  40     (koi8-r cyrillic-iso8859-5)
  41     (iso-8859-6 arabic-iso8859-6)
  42     (iso-8859-7 greek-iso8859-7)
  43     (iso-8859-8 hebrew-iso8859-8)
  44     (iso-8859-9 latin-iso8859-9)
  45     (iso-2022-jp latin-jisx0201
  46                  japanese-jisx0208-1978 japanese-jisx0208)
  47     (euc-kr korean-ksc5601)
  48     (cn-gb-2312 chinese-gb2312)
  49     (cn-big5 chinese-big5-1 chinese-big5-2)
  50     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
  51                    latin-jisx0201 japanese-jisx0208-1978
  52                    chinese-gb2312 japanese-jisx0208
  53                    korean-ksc5601 japanese-jisx0212)
  54     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
  55                     latin-jisx0201 japanese-jisx0208-1978
  56                     chinese-gb2312 japanese-jisx0208
  57                     korean-ksc5601 japanese-jisx0212
  58                     chinese-cns11643-1 chinese-cns11643-2)
  59     (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
  60                     cyrillic-iso8859-5 greek-iso8859-7
  61                     latin-jisx0201 japanese-jisx0208-1978
  62                     chinese-gb2312 japanese-jisx0208
  63                     korean-ksc5601 japanese-jisx0212
  64                     chinese-cns11643-1 chinese-cns11643-2
  65                     chinese-cns11643-3 chinese-cns11643-4
  66                     chinese-cns11643-5 chinese-cns11643-6
  67                     chinese-cns11643-7))
  68   "Alist of MIME-charset/MULE-charsets.")
  69
  70
  71 (eval-and-compile
  72   (mapcar
  73    (lambda (elem)
  74      (let ((nfunc (intern (format "mm-%s" (car elem)))))
  75        (if (fboundp (car elem))
  76            (fset nfunc (car elem))
  77          (fset nfunc (cdr elem)))))
  78    '((decode-coding-string . (lambda (s a) s))
  79      (encode-coding-string . (lambda (s a) s))
  80      (encode-coding-region . ignore)
  81      (decode-coding-region . ignore)
  82      (coding-system-list . ignore)
  83      (char-int . identity)
  84      (device-type . ignore)
  85      (coding-system-equal . equal)
  86      (annotationp . ignore)
  87      (make-char
  88       . (lambda (charset int)
  89           (int-to-char int)))
  90      (read-coding-system
  91       . (lambda (prompt)
  92           "Prompt the user for a coding system."
  93           (completing-read
  94            prompt (mapcar (lambda (s) (list (symbol-name (car s))))
  95                           mm-mime-mule-charset-alist)))))))
  96
  97 (defvar mm-charset-coding-system-alist
  98   (let ((rest
  99          '((us-ascii . iso-8859-1)
 100            (gb2312 . cn-gb-2312)
 101            (iso-2022-jp-2 . iso-2022-7bit-ss2)
 102            (x-ctext . ctext)))
 103         (systems (mm-coding-system-list))
 104         dest)
 105     (while rest
 106       (let ((pair (car rest)))
 107         (unless (memq (car pair) systems)
 108           (setq dest (cons pair dest))))
 109       (setq rest (cdr rest)))
 110     dest)
 111   "Charset/coding system alist.")
 112
 113
 114 (defun mm-mule-charset-to-mime-charset (charset)
 115   "Return the MIME charset corresponding to MULE CHARSET."
 116   (let ((alist mm-mime-mule-charset-alist)
 117         out)
 118     (while alist
 119       (when (memq charset (cdar alist))
 120         (setq out (caar alist)
 121               alist nil))
 122       (pop alist))
 123     out))
 124
 125 (defun mm-charset-to-coding-system (charset &optional lbt)
 126   "Return coding-system corresponding to CHARSET.
 127 CHARSET is a symbol naming a MIME charset.
 128 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
 129 used as the line break code type of the coding system."
 130   (when (stringp charset)
 131     (setq charset (intern (downcase charset))))
 132   (setq charset
 133         (or (cdr (assq charset mm-charset-coding-system-alist))
 134             charset))
 135   (when lbt
 136     (setq charset (intern (format "%s-%s" charset lbt))))
 137   (cond
 138    ;; Running in a non-MULE environment.
 139    ((and (null (mm-coding-system-list))
 140          (memq charset mm-known-charsets))
 141     charset)
 142    ;; Check to see whether we can handle this charset.
 143    ((memq charset (mm-coding-system-list))
 144     charset)
 145    ;; Nope.
 146    (t
 147     nil)))
 148
 149 (defun mm-replace-chars-in-string (string from to)
 150   "Replace characters in STRING from FROM to TO."
 151   (let ((string (substring string 0))   ;Copy string.
 152         (len (length string))
 153         (idx 0))
 154     ;; Replace all occurrences of FROM with TO.
 155     (while (< idx len)
 156       (when (= (aref string idx) from)
 157         (aset string idx to))
 158       (setq idx (1+ idx)))
 159     string))
 160
 161 (defsubst mm-enable-multibyte ()
 162   "Enable multibyte in the current buffer."
 163   (when (fboundp 'set-buffer-multibyte)
 164     (set-buffer-multibyte t)))
 165
 166 (defun mm-mime-charset (charset b e)
 167   (if (fboundp 'coding-system-get)
 168       (or
 169        (and
 170         mm-default-coding-system
 171         (let ((safe (coding-system-get mm-default-coding-system
 172                                        'safe-charsets)))
 173           (or (eq safe t) (memq charset safe)))
 174         (coding-system-get mm-default-coding-system 'mime-charset))
 175        (coding-system-get
 176         (get-charset-property charset 'prefered-coding-system)
 177         'mime-charset)
 178        (car (memq charset (find-coding-systems-region
 179                            (point-min) (point-max)))))
 180     (mm-mule-charset-to-mime-charset charset)))
 181
 182 (defsubst mm-multibyte-p ()
 183   "Say whether multibyte is enabled."
 184   (and (boundp 'enable-multibyte-characters)
 185        enable-multibyte-characters))
 186
 187 (defmacro mm-with-unibyte-buffer (&rest forms)
 188   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 189 See also `with-temp-file' and `with-output-to-string'."
 190   (let ((temp-buffer (make-symbol "temp-buffer"))
 191         (multibyte (make-symbol "multibyte")))
 192     `(if (not (boundp 'enable-multibyte-characters))
 193          (with-temp-buffer ,@forms)
 194        (let ((,multibyte (default-value enable-multibyte-characters))
 195              ,temp-buffer)
 196          (setq-default enable-multibyte-characters nil)
 197          (setq ,temp-buffer
 198                (get-buffer-create (generate-new-buffer-name " *temp*")))
 199          (unwind-protect
 200              (with-current-buffer ,temp-buffer
 201                ,@forms)
 202            (and (buffer-name ,temp-buffer)
 203                 (kill-buffer ,temp-buffer))
 204            (setq-default enable-multibyte-characters ,multibyte))))))
 205 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
 206 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
 207
 208
 209 (provide 'mm-util)
 210
 211 ;;; mm-util.el ends here