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-known-charsets '(iso-8859-1)
  28   "List of known charsets.")
  29
  30 (defvar mm-mime-mule-charset-alist
  31   '((us-ascii ascii)
  32     (iso-8859-1 latin-iso8859-1)
  33     (iso-8859-2 latin-iso8859-2)
  34     (iso-8859-3 latin-iso8859-3)
  35     (iso-8859-4 latin-iso8859-4)
  36     (iso-8859-5 cyrillic-iso8859-5)
  37     (koi8-r cyrillic-iso8859-5)
  38     (iso-8859-6 arabic-iso8859-6)
  39     (iso-8859-7 greek-iso8859-7)
  40     (iso-8859-8 hebrew-iso8859-8)
  41     (iso-8859-9 latin-iso8859-9)
  42     (iso-2022-jp latin-jisx0201
  43                  japanese-jisx0208-1978 japanese-jisx0208)
  44     (euc-kr korean-ksc5601)
  45     (cn-gb-2312 chinese-gb2312)
  46     (cn-big5 chinese-big5-1 chinese-big5-2)
  47     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
  48                    latin-jisx0201 japanese-jisx0208-1978
  49                    chinese-gb2312 japanese-jisx0208
  50                    korean-ksc5601 japanese-jisx0212)
  51     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
  52                     latin-jisx0201 japanese-jisx0208-1978
  53                     chinese-gb2312 japanese-jisx0208
  54                     korean-ksc5601 japanese-jisx0212
  55                     chinese-cns11643-1 chinese-cns11643-2)
  56     (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
  57                     cyrillic-iso8859-5 greek-iso8859-7
  58                     latin-jisx0201 japanese-jisx0208-1978
  59                     chinese-gb2312 japanese-jisx0208
  60                     korean-ksc5601 japanese-jisx0212
  61                     chinese-cns11643-1 chinese-cns11643-2
  62                     chinese-cns11643-3 chinese-cns11643-4
  63                     chinese-cns11643-5 chinese-cns11643-6
  64                     chinese-cns11643-7))
  65   "Alist of MIME-charset/MULE-charsets.")
  66
  67
  68 (eval-and-compile
  69   (mapcar
  70    (lambda (elem)
  71      (let ((nfunc (intern (format "mm-%s" (car elem)))))
  72        (if (fboundp (car elem))
  73            (fset nfunc (car elem))
  74          (fset nfunc (cdr elem)))))
  75    '((decode-coding-string . (lambda (s a) s))
  76      (encode-coding-string . (lambda (s a) s))
  77      (encode-coding-region . ignore)
  78      (decode-coding-region . ignore)
  79      (coding-system-list . ignore)
  80      (char-int . identity)
  81      (device-type . ignore)
  82      (coding-system-equal . equal)
  83      (annotationp . ignore)
  84      (make-char
  85       . (lambda (charset int)
  86           (int-to-char int)))
  87      (read-coding-system
  88       . (lambda (prompt)
  89           "Prompt the user for a coding system."
  90           (completing-read
  91            prompt (mapcar (lambda (s) (list (symbol-name (car s))))
  92                           mm-mime-mule-charset-alist)))))))
  93
  94 (defvar mm-charset-coding-system-alist
  95   (let ((rest
  96          '((us-ascii . iso-8859-1)
  97            (gb2312 . cn-gb-2312)
  98            (iso-2022-jp-2 . iso-2022-7bit-ss2)
  99            (x-ctext . ctext)))
 100         (systems (mm-coding-system-list))
 101         dest)
 102     (while rest
 103       (let ((pair (car rest)))
 104         (unless (memq (car pair) systems)
 105           (setq dest (cons pair dest))))
 106       (setq rest (cdr rest)))
 107     dest)
 108   "Charset/coding system alist.")
 109
 110
 111 (defun mm-mule-charset-to-mime-charset (charset)
 112   "Return the MIME charset corresponding to MULE CHARSET."
 113   (let ((alist mm-mime-mule-charset-alist)
 114         out)
 115     (while alist
 116       (when (memq charset (cdar alist))
 117         (setq out (caar alist)
 118               alist nil))
 119       (pop alist))
 120     out))
 121
 122 (defun mm-charset-to-coding-system (charset &optional lbt)
 123   "Return coding-system corresponding to CHARSET.
 124 CHARSET is a symbol naming a MIME charset.
 125 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
 126 used as the line break code type of the coding system."
 127   (when (stringp charset)
 128     (setq charset (intern (downcase charset))))
 129   (setq charset
 130         (or (cdr (assq charset mm-charset-coding-system-alist))
 131             charset))
 132   (when lbt
 133     (setq charset (intern (format "%s-%s" charset lbt))))
 134   (cond
 135    ;; Running in a non-MULE environment.
 136    ((and (null (mm-coding-system-list))
 137          (memq charset mm-known-charsets))
 138     charset)
 139    ;; Check to see whether we can handle this charset.
 140    ((memq charset (mm-coding-system-list))
 141     charset)
 142    ;; Nope.
 143    (t
 144     nil)))
 145
 146 (defun mm-replace-chars-in-string (string from to)
 147   "Replace characters in STRING from FROM to TO."
 148   (let ((string (substring string 0))   ;Copy string.
 149         (len (length string))
 150         (idx 0))
 151     ;; Replace all occurrences of FROM with TO.
 152     (while (< idx len)
 153       (when (= (aref string idx) from)
 154         (aset string idx to))
 155       (setq idx (1+ idx)))
 156     string))
 157
 158 (defsubst mm-enable-multibyte ()
 159   "Enable multibyte in the current buffer."
 160   (when (fboundp 'set-buffer-multibyte)
 161     (set-buffer-multibyte t)))
 162
 163 (defun mm-insert-rfc822-headers (charset encoding)
 164   "Insert text/plain headers with CHARSET and ENCODING."
 165   (insert "MIME-Version: 1.0\n")
 166   (insert "Content-Type: text/plain; charset=\""
 167           (downcase (symbol-name charset)) "\"\n")
 168   (insert "Content-Transfer-Encoding: "
 169           (downcase (symbol-name encoding)) "\n"))
 170
 171 (defun mm-mime-charset (charset b e)
 172   (if (fboundp 'coding-system-get)
 173       (or
 174        (coding-system-get
 175         (get-charset-property charset 'prefered-coding-system)
 176         'mime-charset)
 177        (car (memq charset (find-coding-systems-region
 178                            (point-min) (point-max)))))
 179     (mm-mule-charset-to-mime-charset charset)))
 180
 181 (defsubst mm-multibyte-p ()
 182   "Say whether multibyte is enabled."
 183   (and (boundp 'enable-multibyte-characters)
 184        enable-multibyte-characters))
 185
 186 (defmacro mm-with-unibyte-buffer (&rest forms)
 187   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 188 See also `with-temp-file' and `with-output-to-string'."
 189   (let ((temp-buffer (make-symbol "temp-buffer"))
 190         (multibyte (make-symbol "multibyte")))
 191     `(if (not (boundp 'enable-multibyte-characters))
 192          (with-temp-buffer ,@forms)
 193        (let ((,multibyte (default-value enable-multibyte-characters))
 194              ,temp-buffer)
 195          (setq-default enable-multibyte-characters nil)
 196          (setq ,temp-buffer
 197                (get-buffer-create (generate-new-buffer-name " *temp*")))
 198          (unwind-protect
 199              (with-current-buffer ,temp-buffer
 200                ,@forms)
 201            (and (buffer-name ,temp-buffer)
 202                 (kill-buffer ,temp-buffer))
 203            (setq-default enable-multibyte-characters ,multibyte))))))
 204
 205 (provide 'mm-util)
 206
 207 ;;; mm-util.el ends here