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