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      (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 ;;;Internal variable
 120 (defvar mm-charset-iso-8859-1-forced nil)
 121
 122 (defun mm-mule-charset-to-mime-charset (charset)
 123   "Return the MIME charset corresponding to MULE CHARSET."
 124   (let ((alist mm-mime-mule-charset-alist)
 125         out)
 126     (while alist
 127       (when (memq charset (cdar alist))
 128         (setq out (caar alist)
 129               alist nil))
 130       (pop alist))
 131     out))
 132
 133 (defun mm-charset-to-coding-system (charset &optional lbt)
 134   "Return coding-system corresponding to CHARSET.
 135 CHARSET is a symbol naming a MIME charset.
 136 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
 137 used as the line break code type of the coding system."
 138   (when (stringp charset)
 139     (setq charset (intern (downcase charset))))
 140   (if (and mm-charset-iso-8859-1-forced
 141            (eq charset 'iso-8859-1))
 142       (setq charset mm-charset-iso-8859-1-forced))
 143   (setq charset
 144         (or (cdr (assq charset mm-charset-coding-system-alist))
 145             charset))
 146   (when lbt
 147     (setq charset (intern (format "%s-%s" charset lbt))))
 148   (cond
 149    ;; Running in a non-MULE environment.
 150    ((and (null (mm-get-coding-system-list))
 151          (memq charset mm-known-charsets))
 152     charset)
 153    ;; ascii
 154    ((eq charset 'us-ascii)
 155     'ascii)
 156    ;; Check to see whether we can handle this charset.
 157    ((memq charset (mm-get-coding-system-list))
 158     charset)
 159    ;; Nope.
 160    (t
 161     nil)))
 162
 163 (defun mm-replace-chars-in-string (string from to)
 164   "Replace characters in STRING from FROM to TO."
 165   (let ((string (substring string 0))   ;Copy string.
 166         (len (length string))
 167         (idx 0))
 168     ;; Replace all occurrences of FROM with TO.
 169     (while (< idx len)
 170       (when (= (aref string idx) from)
 171         (aset string idx to))
 172       (setq idx (1+ idx)))
 173     string))
 174
 175 (defsubst mm-enable-multibyte ()
 176   "Enable multibyte in the current buffer."
 177   (when (and (fboundp 'set-buffer-multibyte)
 178              (default-value 'enable-multibyte-characters))
 179     (set-buffer-multibyte t)))
 180
 181 (defsubst mm-disable-multibyte ()
 182   "Disable multibyte in the current buffer."
 183   (when (fboundp 'set-buffer-multibyte)
 184     (set-buffer-multibyte nil)))
 185
 186 (defun mm-mime-charset (charset b e)
 187   (if (fboundp 'coding-system-get)
 188       (or
 189        (and
 190         mm-default-coding-system
 191         (let ((safe (coding-system-get mm-default-coding-system
 192                                        'safe-charsets)))
 193           (or (eq safe t) (memq charset safe)))
 194         (coding-system-get mm-default-coding-system 'mime-charset))
 195        (coding-system-get
 196         (get-charset-property charset 'prefered-coding-system)
 197         'mime-charset)
 198        (car (memq charset (find-coding-systems-region
 199                            (point-min) (point-max)))))
 200     (mm-mule-charset-to-mime-charset charset)))
 201
 202 (defsubst mm-multibyte-p ()
 203   "Say whether multibyte is enabled."
 204   (and (boundp 'enable-multibyte-characters)
 205        enable-multibyte-characters))
 206
 207 (defmacro mm-with-unibyte-buffer (&rest forms)
 208   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 209 See also `with-temp-file' and `with-output-to-string'."
 210   (let ((temp-buffer (make-symbol "temp-buffer"))
 211         (multibyte (make-symbol "multibyte")))
 212     `(if (not (boundp 'enable-multibyte-characters))
 213          (with-temp-buffer ,@forms)
 214        (let ((,multibyte (default-value 'enable-multibyte-characters))
 215              ,temp-buffer)
 216          (unwind-protect
 217              (progn
 218                (setq-default enable-multibyte-characters nil)
 219                (setq ,temp-buffer
 220                      (get-buffer-create (generate-new-buffer-name " *temp*")))
 221                (unwind-protect
 222                    (with-current-buffer ,temp-buffer
 223                      (let ((buffer-file-coding-system 'binary))
 224                        ,@forms))
 225                  (and (buffer-name ,temp-buffer)
 226                       (kill-buffer ,temp-buffer))))
 227            (setq-default enable-multibyte-characters ,multibyte))))))
 228 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
 229 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
 230
 231 (defun mm-find-charset-region (b e)
 232   "Return a list of charsets in the region."
 233   (cond
 234    ((and (boundp 'enable-multibyte-characters)
 235          enable-multibyte-characters)
 236     (find-charset-region b e))
 237    ((not (boundp 'current-language-environment))
 238     (save-excursion
 239       (save-restriction
 240         (narrow-to-region b e)
 241         (goto-char (point-min))
 242         (skip-chars-forward "\0-\177")
 243         (if (eobp)
 244             '(ascii)
 245           ;;;!!!bogus
 246           (list 'ascii 'latin-iso8859-1)))))
 247    (t
 248     ;; We are in a unibyte buffer, so we futz around a bit.
 249     (save-excursion
 250       (save-restriction
 251         (narrow-to-region b e)
 252         (goto-char (point-min))
 253         (let ((entry (assoc (capitalize current-language-environment)
 254                             language-info-alist)))
 255           (skip-chars-forward "\0-\177")
 256           (if (eobp)
 257               '(ascii)
 258             (list 'ascii (car (last (assq 'charset entry)))))))))))
 259
 260 (provide 'mm-util)
 261
 262 ;;; mm-util.el ends here