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-running-xemacs (string-match "XEmacs" emacs-version))
  28
  29 (defvar mm-binary-coding-system
  30     (if mm-running-xemacs
  31         'binary 'no-conversion)
  32     "100% binary coding system.")
  33
  34 (defvar mm-default-coding-system nil
  35   "The default coding system to use.")
  36
  37 (defvar mm-known-charsets '(iso-8859-1)
  38   "List of known charsets.
  39 Use this under non-Mule Emacsen to specify which charsets your Emacs
  40 can display.  Also see `mm-default-charset'.")
  41
  42 (defvar mm-default-charset 'iso-8859-1
  43   "Default charset assumed to be used when viewing non-ASCII characters.
  44 This variable is used only in non-Mule Emacsen.")
  45
  46 (defvar mm-mime-mule-charset-alist
  47   '((us-ascii ascii)
  48     (iso-8859-1 latin-iso8859-1)
  49     (iso-8859-2 latin-iso8859-2)
  50     (iso-8859-3 latin-iso8859-3)
  51     (iso-8859-4 latin-iso8859-4)
  52     (iso-8859-5 cyrillic-iso8859-5)
  53     (koi8-r cyrillic-iso8859-5)
  54     (iso-8859-6 arabic-iso8859-6)
  55     (iso-8859-7 greek-iso8859-7)
  56     (iso-8859-8 hebrew-iso8859-8)
  57     (iso-8859-9 latin-iso8859-9)
  58     (iso-2022-jp-2 japanese-jisx0208)
  59     (iso-2022-jp latin-jisx0201
  60                  japanese-jisx0208-1978)
  61     (euc-kr korean-ksc5601)
  62     (cn-gb-2312 chinese-gb2312)
  63     (cn-big5 chinese-big5-1 chinese-big5-2)
  64     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
  65                    latin-jisx0201 japanese-jisx0208-1978
  66                    chinese-gb2312 japanese-jisx0208
  67                    korean-ksc5601 japanese-jisx0212)
  68     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
  69                     latin-jisx0201 japanese-jisx0208-1978
  70                     chinese-gb2312 japanese-jisx0208
  71                     korean-ksc5601 japanese-jisx0212
  72                     chinese-cns11643-1 chinese-cns11643-2)
  73     (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
  74                     cyrillic-iso8859-5 greek-iso8859-7
  75                     latin-jisx0201 japanese-jisx0208-1978
  76                     chinese-gb2312 japanese-jisx0208
  77                     korean-ksc5601 japanese-jisx0212
  78                     chinese-cns11643-1 chinese-cns11643-2
  79                     chinese-cns11643-3 chinese-cns11643-4
  80                     chinese-cns11643-5 chinese-cns11643-6
  81                     chinese-cns11643-7))
  82   "Alist of MIME-charset/MULE-charsets.")
  83
  84
  85 (eval-and-compile
  86   (mapcar
  87    (lambda (elem)
  88      (let ((nfunc (intern (format "mm-%s" (car elem)))))
  89        (if (fboundp (car elem))
  90            (fset nfunc (car elem))
  91          (fset nfunc (cdr elem)))))
  92    '((decode-coding-string . (lambda (s a) s))
  93      (encode-coding-string . (lambda (s a) s))
  94      (encode-coding-region . ignore)
  95      (coding-system-list . ignore)
  96      (decode-coding-region . ignore)
  97      (char-int . identity)
  98      (device-type . ignore)
  99      (coding-system-equal . equal)
 100      (annotationp . ignore)
 101      (set-buffer-file-coding-system . ignore)
 102      (make-char
 103       . (lambda (charset int)
 104           (int-to-char int)))
 105      (read-coding-system
 106       . (lambda (prompt)
 107           "Prompt the user for a coding system."
 108           (completing-read
 109            prompt (mapcar (lambda (s) (list (symbol-name (car s))))
 110                           mm-mime-mule-charset-alist)))))))
 111
 112 (defvar mm-coding-system-list nil)
 113 (defun mm-get-coding-system-list ()
 114   "Get the coding system list."
 115   (or mm-coding-system-list
 116       (setq mm-coding-system-list (mm-coding-system-list))))
 117
 118 (defvar mm-charset-coding-system-alist
 119   (let ((rest
 120          '((gb2312 . cn-gb-2312)
 121            (iso-2022-jp-2 . iso-2022-7bit-ss2)
 122            (x-ctext . ctext)))
 123         (systems (mm-get-coding-system-list))
 124         dest)
 125     (while rest
 126       (let ((pair (car rest)))
 127         (unless (memq (car pair) systems)
 128           (setq dest (cons pair dest))))
 129       (setq rest (cdr rest)))
 130     dest)
 131   "Charset/coding system alist.")
 132
 133 ;;;Internal variable
 134 (defvar mm-charset-iso-8859-1-forced nil)
 135
 136 (defun mm-mule-charset-to-mime-charset (charset)
 137   "Return the MIME charset corresponding to MULE CHARSET."
 138   (let ((alist mm-mime-mule-charset-alist)
 139         out)
 140     (while alist
 141       (when (memq charset (cdar alist))
 142         (setq out (caar alist)
 143               alist nil))
 144       (pop alist))
 145     out))
 146
 147 (defun mm-charset-to-coding-system (charset &optional lbt)
 148   "Return coding-system corresponding to CHARSET.
 149 CHARSET is a symbol naming a MIME charset.
 150 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
 151 used as the line break code type of the coding system."
 152   (when (stringp charset)
 153     (setq charset (intern (downcase charset))))
 154   (if (and mm-charset-iso-8859-1-forced
 155            (eq charset 'iso-8859-1))
 156       (setq charset mm-charset-iso-8859-1-forced))
 157   (setq charset
 158         (or (cdr (assq charset mm-charset-coding-system-alist))
 159             charset))
 160   (when lbt
 161     (setq charset (intern (format "%s-%s" charset lbt))))
 162   (cond
 163    ;; Running in a non-MULE environment.
 164    ((and (null (mm-get-coding-system-list))
 165          (or (eq charset mm-default-charset)
 166              (memq charset mm-known-charsets)))
 167     charset)
 168    ;; ascii
 169    ((eq charset 'us-ascii)
 170     'ascii)
 171    ;; Check to see whether we can handle this charset.
 172    ((memq charset (mm-get-coding-system-list))
 173     charset)
 174    ;; Nope.
 175    (t
 176     nil)))
 177
 178 (defun mm-replace-chars-in-string (string from to)
 179   "Replace characters in STRING from FROM to TO."
 180   (let ((string (substring string 0))   ;Copy string.
 181         (len (length string))
 182         (idx 0))
 183     ;; Replace all occurrences of FROM with TO.
 184     (while (< idx len)
 185       (when (= (aref string idx) from)
 186         (aset string idx to))
 187       (setq idx (1+ idx)))
 188     string))
 189
 190 (defsubst mm-enable-multibyte ()
 191   "Enable multibyte in the current buffer."
 192   (when (and (fboundp 'set-buffer-multibyte)
 193              (default-value 'enable-multibyte-characters))
 194     (set-buffer-multibyte t)))
 195
 196 (defsubst mm-disable-multibyte ()
 197   "Disable multibyte in the current buffer."
 198   (when (fboundp 'set-buffer-multibyte)
 199     (set-buffer-multibyte nil)))
 200
 201 (defun mm-mime-charset (charset b e)
 202   (if (fboundp 'coding-system-get)
 203       (or
 204        (and
 205         mm-default-coding-system
 206         (let ((safe (coding-system-get mm-default-coding-system
 207                                        'safe-charsets)))
 208           (or (eq safe t) (memq charset safe)))
 209         (coding-system-get mm-default-coding-system 'mime-charset))
 210        (coding-system-get
 211         (get-charset-property charset 'prefered-coding-system)
 212         'mime-charset)
 213        (car (memq charset (find-coding-systems-region
 214                            (point-min) (point-max)))))
 215     (mm-mule-charset-to-mime-charset charset)))
 216
 217 (defsubst mm-multibyte-p ()
 218   "Say whether multibyte is enabled."
 219   (and (boundp 'enable-multibyte-characters)
 220        enable-multibyte-characters))
 221
 222 (defmacro mm-with-unibyte-buffer (&rest forms)
 223   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 224 See also `with-temp-file' and `with-output-to-string'."
 225   (let ((temp-buffer (make-symbol "temp-buffer"))
 226         (multibyte (make-symbol "multibyte")))
 227     `(if (not (boundp 'enable-multibyte-characters))
 228          (with-temp-buffer ,@forms)
 229        (let ((,multibyte (default-value 'enable-multibyte-characters))
 230              ,temp-buffer)
 231          (unwind-protect
 232              (progn
 233                (setq-default enable-multibyte-characters nil)
 234                (setq ,temp-buffer
 235                      (get-buffer-create (generate-new-buffer-name " *temp*")))
 236                (unwind-protect
 237                    (with-current-buffer ,temp-buffer
 238                      (let ((buffer-file-coding-system mm-binary-coding-system)
 239                            (coding-system-for-read mm-binary-coding-system)
 240                            (coding-system-for-write mm-binary-coding-system))
 241                        ,@forms))
 242                  (and (buffer-name ,temp-buffer)
 243                       (kill-buffer ,temp-buffer))))
 244            (setq-default enable-multibyte-characters ,multibyte))))))
 245 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
 246 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
 247
 248 (defun mm-find-charset-region (b e)
 249   "Return a list of charsets in the region."
 250   (cond
 251    ((and (boundp 'enable-multibyte-characters)
 252          enable-multibyte-characters)
 253     (find-charset-region b e))
 254    ((not (boundp 'current-language-environment))
 255     (save-excursion
 256       (save-restriction
 257         (narrow-to-region b e)
 258         (goto-char (point-min))
 259         (skip-chars-forward "\0-\177")
 260         (if (eobp)
 261             '(ascii)
 262           ;;;!!!bogus
 263           (list 'ascii 'latin-iso8859-1)))))
 264    (t
 265     ;; We are in a unibyte buffer, so we futz around a bit.
 266     (save-excursion
 267       (save-restriction
 268         (narrow-to-region b e)
 269         (goto-char (point-min))
 270         (let ((entry (assoc (capitalize current-language-environment)
 271                             language-info-alist)))
 272           (skip-chars-forward "\0-\177")
 273           (if (eobp)
 274               '(ascii)
 275             (list 'ascii (car (last (assq 'charset entry)))))))))))
 276
 277 (provide 'mm-util)
 278
 279 ;;; mm-util.el ends here