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