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