cgit.sxemacs.org Git - gnus/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      (coding-system-list . ignore)
  82      (decode-coding-region . ignore)
  83      (char-int . identity)
  84      (device-type . ignore)
  85      (coding-system-equal . equal)
  86      (annotationp . ignore)
  87      (set-buffer-file-coding-system . ignore)
  88      (make-char
  89       . (lambda (charset int)
  90           (int-to-char int)))
  91      (read-coding-system
  92       . (lambda (prompt)
  93           "Prompt the user for a coding system."
  94           (completing-read
  95            prompt (mapcar (lambda (s) (list (symbol-name (car s))))
  96                           mm-mime-mule-charset-alist)))))))
  97
  98 (defvar mm-coding-system-list nil)
  99 (defun mm-get-coding-system-list ()
 100   "Get the coding system list."
 101   (or mm-coding-system-list
 102       (setq mm-coding-system-list (mm-coding-system-list))))
 103
 104 (defvar mm-charset-coding-system-alist
 105   (let ((rest
 106          '((gb2312 . cn-gb-2312)
 107            (iso-2022-jp-2 . iso-2022-7bit-ss2)
 108            (x-ctext . ctext)))
 109         (systems (mm-get-coding-system-list))
 110         dest)
 111     (while rest
 112       (let ((pair (car rest)))
 113         (unless (memq (car pair) systems)
 114           (setq dest (cons pair dest))))
 115       (setq rest (cdr rest)))
 116     dest)
 117   "Charset/coding system alist.")
 118
 119 (defun mm-mule-charset-to-mime-charset (charset)
 120   "Return the MIME charset corresponding to MULE CHARSET."
 121   (let ((alist mm-mime-mule-charset-alist)
 122         out)
 123     (while alist
 124       (when (memq charset (cdar alist))
 125         (setq out (caar alist)
 126               alist nil))
 127       (pop alist))
 128     out))
 129
 130 (defun mm-charset-to-coding-system (charset &optional lbt)
 131   "Return coding-system corresponding to CHARSET.
 132 CHARSET is a symbol naming a MIME charset.
 133 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
 134 used as the line break code type of the coding system."
 135   (when (stringp charset)
 136     (setq charset (intern (downcase charset))))
 137   (setq charset
 138         (or (cdr (assq charset mm-charset-coding-system-alist))
 139             charset))
 140   (when lbt
 141     (setq charset (intern (format "%s-%s" charset lbt))))
 142   (cond
 143    ;; Running in a non-MULE environment.
 144    ((and (null (mm-get-coding-system-list))
 145          (memq charset mm-known-charsets))
 146     charset)
 147    ;; ascii
 148    ((eq charset 'us-ascii)
 149     'ascii)
 150    ;; Check to see whether we can handle this charset.
 151    ((memq charset (mm-get-coding-system-list))
 152     charset)
 153    ;; Nope.
 154    (t
 155     nil)))
 156
 157 (defun mm-replace-chars-in-string (string from to)
 158   "Replace characters in STRING from FROM to TO."
 159   (let ((string (substring string 0))   ;Copy string.
 160         (len (length string))
 161         (idx 0))
 162     ;; Replace all occurrences of FROM with TO.
 163     (while (< idx len)
 164       (when (= (aref string idx) from)
 165         (aset string idx to))
 166       (setq idx (1+ idx)))
 167     string))
 168
 169 (defsubst mm-enable-multibyte ()
 170   "Enable multibyte in the current buffer."
 171   (when (fboundp 'set-buffer-multibyte)
 172     (set-buffer-multibyte t)))
 173
 174 (defun mm-mime-charset (charset b e)
 175   (if (fboundp 'coding-system-get)
 176       (or
 177        (and
 178         mm-default-coding-system
 179         (let ((safe (coding-system-get mm-default-coding-system
 180                                        'safe-charsets)))
 181           (or (eq safe t) (memq charset safe)))
 182         (coding-system-get mm-default-coding-system 'mime-charset))
 183        (coding-system-get
 184         (get-charset-property charset 'prefered-coding-system)
 185         'mime-charset)
 186        (car (memq charset (find-coding-systems-region
 187                            (point-min) (point-max)))))
 188     (mm-mule-charset-to-mime-charset charset)))
 189
 190 (defsubst mm-multibyte-p ()
 191   "Say whether multibyte is enabled."
 192   (and (boundp 'enable-multibyte-characters)
 193        enable-multibyte-characters))
 194
 195 (defmacro mm-with-unibyte-buffer (&rest forms)
 196   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 197 See also `with-temp-file' and `with-output-to-string'."
 198   (let ((temp-buffer (make-symbol "temp-buffer"))
 199         (multibyte (make-symbol "multibyte")))
 200     `(if (not (boundp 'enable-multibyte-characters))
 201          (with-temp-buffer ,@forms)
 202        (let ((,multibyte (default-value enable-multibyte-characters))
 203              ,temp-buffer)
 204          (setq-default enable-multibyte-characters nil)
 205          (setq ,temp-buffer
 206                (get-buffer-create (generate-new-buffer-name " *temp*")))
 207          (unwind-protect
 208              (with-current-buffer ,temp-buffer
 209                (let (buffer-file-coding-system)
 210                  ,@forms))
 211            (and (buffer-name ,temp-buffer)
 212                 (kill-buffer ,temp-buffer))
 213            (setq-default enable-multibyte-characters ,multibyte))))))
 214 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
 215 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
 216
 217
 218 (provide 'mm-util)
 219
 220 ;;; mm-util.el ends here