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     (x-ctext . ctext))
 130   "A mapping from invalid charset names to the real charset names.")
 131
 132 ;;; Internal variables:
 133
 134 ;;; Functions:
 135
 136 (defun mm-mule-charset-to-mime-charset (charset)
 137   "Return the MIME charset corresponding to MULE CHARSET."
 138   (let ((alist mm-mime-mule-charset-alist)
 139         out)
 140     (while alist
 141       (when (memq charset (cdar alist))
 142         (setq out (caar alist)
 143               alist nil))
 144       (pop alist))
 145     out))
 146
 147 (defun mm-charset-to-coding-system (charset &optional lbt)
 148   "Return coding-system corresponding to CHARSET.
 149 CHARSET is a symbol naming a MIME charset.
 150 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
 151 used as the line break code type of the coding system."
 152   (when (stringp charset)
 153     (setq charset (intern (downcase charset))))
 154   (setq charset
 155         (or (cdr (assq charset mm-charset-synonym-alist))
 156             charset))
 157   (when lbt
 158     (setq charset (intern (format "%s-%s" charset lbt))))
 159   (cond
 160    ;; Running in a non-MULE environment.
 161    ((null (mm-get-coding-system-list))
 162     charset)
 163    ;; ascii
 164    ((eq charset 'us-ascii)
 165     'ascii)
 166    ;; Check to see whether we can handle this charset.
 167    ((memq charset (mm-get-coding-system-list))
 168     charset)
 169    ;; Nope.
 170    (t
 171     nil)))
 172
 173 (defun mm-replace-chars-in-string (string from to)
 174   "Replace characters in STRING from FROM to TO."
 175   (let ((string (substring string 0))   ;Copy string.
 176         (len (length string))
 177         (idx 0))
 178     ;; Replace all occurrences of FROM with TO.
 179     (while (< idx len)
 180       (when (= (aref string idx) from)
 181         (aset string idx to))
 182       (setq idx (1+ idx)))
 183     string))
 184
 185 (defsubst mm-enable-multibyte ()
 186   "Enable multibyte in the current buffer."
 187   (when (and (fboundp 'set-buffer-multibyte)
 188              (default-value 'enable-multibyte-characters))
 189     (set-buffer-multibyte t)))
 190
 191 (defsubst mm-disable-multibyte ()
 192   "Disable multibyte in the current buffer."
 193   (when (fboundp 'set-buffer-multibyte)
 194     (set-buffer-multibyte nil)))
 195
 196 (defun mm-mime-charset (charset)
 197   "Return the MIME charset corresponding to the MULE CHARSET."
 198   (if (fboundp 'coding-system-get)
 199       ;; This exists in Emacs 20.
 200       (or
 201        (and (get-charset-property charset 'prefered-coding-system)
 202             (coding-system-get
 203              (get-charset-property charset 'prefered-coding-system)
 204              'mime-charset))
 205        (and (eq charset 'ascii)
 206             'us-ascii)
 207        (get-charset-property charset 'prefered-coding-system)
 208        (mm-mule-charset-to-mime-charset charset))
 209     ;; This is for XEmacs.
 210     (mm-mule-charset-to-mime-charset charset)))
 211
 212 (defun mm-find-mime-charset-region (b e)
 213   "Return the MIME charsets needed to encode the region between B and E."
 214   (let ((charsets
 215          (mapcar 'mm-mime-charset
 216                  (delq 'ascii
 217                        (mm-find-charset-region b e)))))
 218     (delete-duplicates charsets)))
 219
 220 (defsubst mm-multibyte-p ()
 221   "Say whether multibyte is enabled."
 222   (and (boundp 'enable-multibyte-characters)
 223        enable-multibyte-characters))
 224
 225 (defmacro mm-with-unibyte-buffer (&rest forms)
 226   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 227 See also `with-temp-file' and `with-output-to-string'."
 228   (let ((temp-buffer (make-symbol "temp-buffer"))
 229         (multibyte (make-symbol "multibyte")))
 230     `(if (not (boundp 'enable-multibyte-characters))
 231          (with-temp-buffer ,@forms)
 232        (let ((,multibyte (default-value 'enable-multibyte-characters))
 233              ,temp-buffer)
 234          (unwind-protect
 235              (progn
 236                (setq-default enable-multibyte-characters nil)
 237                (setq ,temp-buffer
 238                      (get-buffer-create (generate-new-buffer-name " *temp*")))
 239                (unwind-protect
 240                    (with-current-buffer ,temp-buffer
 241                      (let ((buffer-file-coding-system mm-binary-coding-system)
 242                            (coding-system-for-read mm-binary-coding-system)
 243                            (coding-system-for-write mm-binary-coding-system))
 244                        ,@forms))
 245                  (and (buffer-name ,temp-buffer)
 246                       (kill-buffer ,temp-buffer))))
 247            (setq-default enable-multibyte-characters ,multibyte))))))
 248 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
 249 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
 250
 251 (defun mm-find-charset-region (b e)
 252   "Return a list of charsets in the region."
 253   (cond
 254    ((and (boundp 'enable-multibyte-characters)
 255          enable-multibyte-characters
 256          (fboundp 'find-charset-region))
 257     (find-charset-region b e))
 258    ((not (boundp 'current-language-environment))
 259     (save-excursion
 260       (save-restriction
 261         (narrow-to-region b e)
 262         (goto-char (point-min))
 263         (skip-chars-forward "\0-\177")
 264         (if (eobp)
 265             '(ascii)
 266           (delq nil (list 'ascii mail-parse-charset))))))
 267    (t
 268     ;; We are in a unibyte buffer, so we futz around a bit.
 269     (save-excursion
 270       (save-restriction
 271         (narrow-to-region b e)
 272         (goto-char (point-min))
 273         (let ((entry (assoc (capitalize current-language-environment)
 274                             language-info-alist)))
 275           (skip-chars-forward "\0-\177")
 276           (if (eobp)
 277               '(ascii)
 278             (list 'ascii (car (last (assq 'charset entry)))))))))))
 279
 280 (defun mm-read-charset (prompt)
 281   "Return a charset."
 282   (intern
 283    (completing-read
 284     prompt
 285     (mapcar (lambda (e) (list (symbol-name (car e))))
 286             mm-mime-mule-charset-alist)
 287     nil t)))
 288
 289 (defun mm-quote-arg (arg)
 290   "Return a version of ARG that is safe to evaluate in a shell."
 291   (let ((pos 0) new-pos accum)
 292     ;; *** bug: we don't handle newline characters properly
 293     (while (setq new-pos (string-match "[]*[;!'`\"$\\& \t{} |()<>]" arg pos))
 294       (push (substring arg pos new-pos) accum)
 295       (push "\\" accum)
 296       (push (list (aref arg new-pos)) accum)
 297       (setq pos (1+ new-pos)))
 298     (if (= pos 0)
 299         arg
 300       (apply 'concat (nconc (nreverse accum) (list (substring arg pos)))))))
 301
 302 (provide 'mm-util)
 303
 304 ;;; mm-util.el ends here