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