cgit.sxemacs.org Git - gnus/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     (iso-2022-jp-2 japanese-jisx0208)
  62     (iso-2022-jp latin-jisx0201
  63                  japanese-jisx0208-1978)
  64     (euc-kr korean-ksc5601)
  65     (cn-gb-2312 chinese-gb2312)
  66     (cn-big5 chinese-big5-1 chinese-big5-2)
  67     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
  68                    latin-jisx0201 japanese-jisx0208-1978
  69                    chinese-gb2312 japanese-jisx0208
  70                    korean-ksc5601 japanese-jisx0212)
  71     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
  72                     latin-jisx0201 japanese-jisx0208-1978
  73                     chinese-gb2312 japanese-jisx0208
  74                     korean-ksc5601 japanese-jisx0212
  75                     chinese-cns11643-1 chinese-cns11643-2)
  76     (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
  77                     cyrillic-iso8859-5 greek-iso8859-7
  78                     latin-jisx0201 japanese-jisx0208-1978
  79                     chinese-gb2312 japanese-jisx0208
  80                     korean-ksc5601 japanese-jisx0212
  81                     chinese-cns11643-1 chinese-cns11643-2
  82                     chinese-cns11643-3 chinese-cns11643-4
  83                     chinese-cns11643-5 chinese-cns11643-6
  84                     chinese-cns11643-7))
  85   "Alist of MIME-charset/MULE-charsets.")
  86
  87
  88 (eval-and-compile
  89   (mapcar
  90    (lambda (elem)
  91      (let ((nfunc (intern (format "mm-%s" (car elem)))))
  92        (if (fboundp (car elem))
  93            (fset nfunc (car elem))
  94          (fset nfunc (cdr elem)))))
  95    '((decode-coding-string . (lambda (s a) s))
  96      (encode-coding-string . (lambda (s a) s))
  97      (encode-coding-region . ignore)
  98      (coding-system-list . ignore)
  99      (decode-coding-region . ignore)
 100      (char-int . identity)
 101      (device-type . ignore)
 102      (coding-system-equal . equal)
 103      (annotationp . ignore)
 104      (set-buffer-file-coding-system . ignore)
 105      (make-char
 106       . (lambda (charset int)
 107           (int-to-char int)))
 108      (read-coding-system
 109       . (lambda (prompt)
 110           "Prompt the user for a coding system."
 111           (completing-read
 112            prompt (mapcar (lambda (s) (list (symbol-name (car s))))
 113                           mm-mime-mule-charset-alist)))))))
 114
 115 (defvar mm-coding-system-list nil)
 116 (defun mm-get-coding-system-list ()
 117   "Get the coding system list."
 118   (or mm-coding-system-list
 119       (setq mm-coding-system-list (mm-coding-system-list))))
 120
 121 (defvar mm-charset-synonym-alist
 122   '((big5 . cn-big5)
 123     (gb2312 . cn-gb-2312)
 124     (iso-2022-jp-2 . iso-2022-7bit-ss2)
 125     (x-ctext . ctext))
 126   "A mapping from invalid charset names to the real charset names.")
 127
 128 ;;; Internal variables:
 129
 130 ;;; Functions:
 131
 132 (defun mm-mule-charset-to-mime-charset (charset)
 133   "Return the MIME charset corresponding to MULE CHARSET."
 134   (let ((alist mm-mime-mule-charset-alist)
 135         out)
 136     (while alist
 137       (when (memq charset (cdar alist))
 138         (setq out (caar alist)
 139               alist nil))
 140       (pop alist))
 141     out))
 142
 143 (defun mm-charset-to-coding-system (charset &optional lbt)
 144   "Return coding-system corresponding to CHARSET.
 145 CHARSET is a symbol naming a MIME charset.
 146 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
 147 used as the line break code type of the coding system."
 148   (when (stringp charset)
 149     (setq charset (intern (downcase charset))))
 150   (setq charset
 151         (or (cdr (assq charset mm-charset-synonym-alist))
 152             charset))
 153   (when lbt
 154     (setq charset (intern (format "%s-%s" charset lbt))))
 155   (cond
 156    ;; Running in a non-MULE environment.
 157    ((null (mm-get-coding-system-list))
 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)
 193   "Return the MIME charset corresponding to the MULE CHARSET."
 194   (if (fboundp 'coding-system-get)
 195       ;; This exists in Emacs 20.
 196       (or
 197        (and (get-charset-property charset 'prefered-coding-system)
 198             (coding-system-get
 199              (get-charset-property charset 'prefered-coding-system)
 200              'mime-charset))
 201        (and (eq charset 'ascii)
 202             'us-ascii)
 203        (get-charset-property charset 'prefered-coding-system))
 204     ;; This is for XEmacs.
 205     (mm-mule-charset-to-mime-charset charset)))
 206
 207 (defsubst mm-multibyte-p ()
 208   "Say whether multibyte is enabled."
 209   (and (boundp 'enable-multibyte-characters)
 210        enable-multibyte-characters))
 211
 212 (defmacro mm-with-unibyte-buffer (&rest forms)
 213   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 214 See also `with-temp-file' and `with-output-to-string'."
 215   (let ((temp-buffer (make-symbol "temp-buffer"))
 216         (multibyte (make-symbol "multibyte")))
 217     `(if (not (boundp 'enable-multibyte-characters))
 218          (with-temp-buffer ,@forms)
 219        (let ((,multibyte (default-value 'enable-multibyte-characters))
 220              ,temp-buffer)
 221          (unwind-protect
 222              (progn
 223                (setq-default enable-multibyte-characters nil)
 224                (setq ,temp-buffer
 225                      (get-buffer-create (generate-new-buffer-name " *temp*")))
 226                (unwind-protect
 227                    (with-current-buffer ,temp-buffer
 228                      (let ((buffer-file-coding-system mm-binary-coding-system)
 229                            (coding-system-for-read mm-binary-coding-system)
 230                            (coding-system-for-write mm-binary-coding-system))
 231                        ,@forms))
 232                  (and (buffer-name ,temp-buffer)
 233                       (kill-buffer ,temp-buffer))))
 234            (setq-default enable-multibyte-characters ,multibyte))))))
 235 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
 236 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
 237
 238 (defun mm-find-charset-region (b e)
 239   "Return a list of charsets in the region."
 240   (cond
 241    ((and (boundp 'enable-multibyte-characters)
 242          enable-multibyte-characters
 243          (fboundp 'find-charset-region))
 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           (delq nil (list 'ascii mail-parse-charset))))))
 254    (t
 255     ;; We are in a unibyte buffer, so we futz around a bit.
 256     (save-excursion
 257       (save-restriction
 258         (narrow-to-region b e)
 259         (goto-char (point-min))
 260         (let ((entry (assoc (capitalize current-language-environment)
 261                             language-info-alist)))
 262           (skip-chars-forward "\0-\177")
 263           (if (eobp)
 264               '(ascii)
 265             (list 'ascii (car (last (assq 'charset entry)))))))))))
 266
 267 (defun mm-read-charset (prompt)
 268   "Return a charset."
 269   (intern
 270    (completing-read
 271     prompt
 272     (mapcar (lambda (e) (list (symbol-name (car e))))
 273             mm-mime-mule-charset-alist)
 274     nil t)))
 275
 276 (provide 'mm-util)
 277
 278 ;;; mm-util.el ends here