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 (defconst mm-running-xemacs (string-match "XEmacs" emacs-version))
  28
  29 (defconst mm-binary-coding-system
  30   (if mm-running-xemacs
  31       'binary 'no-conversion)
  32   "100% binary coding system.")
  33
  34 (defconst mm-text-coding-system
  35   (and (fboundp 'coding-system-list)
  36    (if (memq system-type '(windows-nt ms-dos ms-windows))
  37        'raw-text-dos 'raw-text))
  38   "Text-safe coding system (For removing ^M).")
  39
  40 (defvar mm-mime-mule-charset-alist
  41   '((us-ascii ascii)
  42     (iso-8859-1 latin-iso8859-1)
  43     (iso-8859-2 latin-iso8859-2)
  44     (iso-8859-3 latin-iso8859-3)
  45     (iso-8859-4 latin-iso8859-4)
  46     (iso-8859-5 cyrillic-iso8859-5)
  47     (koi8-r cyrillic-iso8859-5)
  48     (iso-8859-6 arabic-iso8859-6)
  49     (iso-8859-7 greek-iso8859-7)
  50     (iso-8859-8 hebrew-iso8859-8)
  51     (iso-8859-9 latin-iso8859-9)
  52     (viscii vietnamese-viscii-lower)
  53     (iso-2022-jp latin-jisx0201 japanese-jisx0208 japanese-jisx0208-1978)
  54     (euc-kr korean-ksc5601)
  55     (cn-gb-2312 chinese-gb2312)
  56     (cn-big5 chinese-big5-1 chinese-big5-2)
  57     (tibetan tibetan)
  58     (thai-tis620 thai-tis620)
  59     (iso-2022-7bit ethiopic arabic-1-column arabic-2-column)
  60     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
  61                    latin-jisx0201 japanese-jisx0208-1978
  62                    chinese-gb2312 japanese-jisx0208
  63                    korean-ksc5601 japanese-jisx0212
  64                    katakana-jisx0201)
  65     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
  66                     latin-jisx0201 japanese-jisx0208-1978
  67                     chinese-gb2312 japanese-jisx0208
  68                     korean-ksc5601 japanese-jisx0212
  69                     chinese-cns11643-1 chinese-cns11643-2)
  70     (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
  71                     cyrillic-iso8859-5 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                     chinese-cns11643-3 chinese-cns11643-4
  77                     chinese-cns11643-5 chinese-cns11643-6
  78                     chinese-cns11643-7))
  79   "Alist of MIME-charset/MULE-charsets.")
  80
  81
  82 (eval-and-compile
  83   (mapcar
  84    (lambda (elem)
  85      (let ((nfunc (intern (format "mm-%s" (car elem)))))
  86        (if (fboundp (car elem))
  87            (fset nfunc (car elem))
  88          (fset nfunc (cdr elem)))))
  89    '((decode-coding-string . (lambda (s a) s))
  90      (encode-coding-string . (lambda (s a) s))
  91      (encode-coding-region . ignore)
  92      (coding-system-list . ignore)
  93      (decode-coding-region . ignore)
  94      (char-int . identity)
  95      (device-type . ignore)
  96      (coding-system-equal . equal)
  97      (annotationp . ignore)
  98      (set-buffer-file-coding-system . ignore)
  99      (make-char
 100       . (lambda (charset int)
 101           (int-to-char int)))
 102      (read-coding-system
 103       . (lambda (prompt)
 104           "Prompt the user for a coding system."
 105           (completing-read
 106            prompt (mapcar (lambda (s) (list (symbol-name (car s))))
 107                           mm-mime-mule-charset-alist)))))))
 108
 109 (defvar mm-coding-system-list nil)
 110 (defun mm-get-coding-system-list ()
 111   "Get the coding system list."
 112   (or mm-coding-system-list
 113       (setq mm-coding-system-list (mm-coding-system-list))))
 114
 115 (defvar mm-charset-synonym-alist
 116   '((big5 . cn-big5)
 117     (gb2312 . cn-gb-2312)
 118     (x-ctext . ctext))
 119   "A mapping from invalid charset names to the real charset names.")
 120
 121 (defconst mm-auto-save-coding-system
 122   (cond
 123    ((memq 'emacs-mule (mm-get-coding-system-list))
 124     (if (memq system-type '(windows-nt ms-dos ms-windows))
 125         'emacs-mule-dos 'emacs-mule))
 126    ((memq 'escape-quoted (mm-get-coding-system-list))
 127     'escape-quoted)
 128    ((memq 'no-conversion (mm-get-coding-system-list))
 129     'no-conversion)
 130    (t nil))
 131   "Coding system of auto save file.")
 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              (boundp 'enable-multibyte-characters)
 190              (default-value 'enable-multibyte-characters))
 191     (set-buffer-multibyte t)))
 192
 193 (defsubst mm-disable-multibyte ()
 194   "Disable multibyte in the current buffer."
 195   (when (fboundp 'set-buffer-multibyte)
 196     (set-buffer-multibyte nil)))
 197
 198 (defun mm-preferred-coding-system (charset)
 199   ;; A typo in some Emacs versions.
 200   (or (get-charset-property charset 'prefered-coding-system)
 201       (get-charset-property charset 'preffered-coding-system)))
 202
 203 (defun mm-mime-charset (charset)
 204   "Return the MIME charset corresponding to the MULE CHARSET."
 205   (if (fboundp 'coding-system-get)
 206       ;; This exists in Emacs 20.
 207       (or
 208        (and (mm-preferred-coding-system charset)
 209             (coding-system-get
 210              (mm-preferred-coding-system charset) 'mime-charset))
 211        (and (eq charset 'ascii)
 212             'us-ascii)
 213        (mm-preferred-coding-system charset)
 214        (mm-mule-charset-to-mime-charset charset))
 215     ;; This is for XEmacs.
 216     (mm-mule-charset-to-mime-charset charset)))
 217
 218 (defun mm-find-mime-charset-region (b e)
 219   "Return the MIME charsets needed to encode the region between B and E."
 220   (let ((charsets
 221          (mapcar 'mm-mime-charset
 222                  (delq 'ascii
 223                        (mm-find-charset-region b e)))))
 224     (when (memq 'iso-2022-jp-2 charsets)
 225       (setq charsets (delq 'iso-2022-jp charsets)))
 226     (delete-duplicates charsets)))
 227
 228 (defsubst mm-multibyte-p ()
 229   "Say whether multibyte is enabled."
 230   (and (boundp 'enable-multibyte-characters)
 231        enable-multibyte-characters))
 232
 233 (defmacro mm-with-unibyte-buffer (&rest forms)
 234   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 235 See also `with-temp-file' and `with-output-to-string'."
 236   (let ((temp-buffer (make-symbol "temp-buffer"))
 237         (multibyte (make-symbol "multibyte")))
 238     `(if (not (boundp 'enable-multibyte-characters))
 239          (with-temp-buffer ,@forms)
 240        (let ((,multibyte (default-value 'enable-multibyte-characters))
 241              ,temp-buffer)
 242          (unwind-protect
 243              (progn
 244                (setq-default enable-multibyte-characters nil)
 245                (setq ,temp-buffer
 246                      (get-buffer-create (generate-new-buffer-name " *temp*")))
 247                (unwind-protect
 248                    (with-current-buffer ,temp-buffer
 249                      (let ((buffer-file-coding-system mm-binary-coding-system)
 250                            (coding-system-for-read mm-binary-coding-system)
 251                            (coding-system-for-write mm-binary-coding-system))
 252                        ,@forms))
 253                  (and (buffer-name ,temp-buffer)
 254                       (kill-buffer ,temp-buffer))))
 255            (setq-default enable-multibyte-characters ,multibyte))))))
 256 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
 257 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
 258
 259 (defun mm-find-charset-region (b e)
 260   "Return a list of charsets in the region."
 261   (cond
 262    ((and (boundp 'enable-multibyte-characters)
 263          enable-multibyte-characters
 264          (fboundp 'find-charset-region))
 265     (find-charset-region b e))
 266    ((not (boundp 'current-language-environment))
 267     (save-excursion
 268       (save-restriction
 269         (narrow-to-region b e)
 270         (goto-char (point-min))
 271         (skip-chars-forward "\0-\177")
 272         (if (eobp)
 273             '(ascii)
 274           (delq nil (list 'ascii mail-parse-charset))))))
 275    (t
 276     ;; We are in a unibyte buffer, so we futz around a bit.
 277     (save-excursion
 278       (save-restriction
 279         (narrow-to-region b e)
 280         (goto-char (point-min))
 281         (let ((entry (assoc (capitalize current-language-environment)
 282                             language-info-alist)))
 283           (skip-chars-forward "\0-\177")
 284           (if (eobp)
 285               '(ascii)
 286             (list 'ascii (car (last (assq 'charset entry)))))))))))
 287
 288 (defun mm-read-charset (prompt)
 289   "Return a charset."
 290   (intern
 291    (completing-read
 292     prompt
 293     (mapcar (lambda (e) (list (symbol-name (car e))))
 294             mm-mime-mule-charset-alist)
 295     nil t)))
 296
 297 (defun mm-quote-arg (arg)
 298   "Return a version of ARG that is safe to evaluate in a shell."
 299   (let ((pos 0) new-pos accum)
 300     ;; *** bug: we don't handle newline characters properly
 301     (while (setq new-pos (string-match "[]*[;!'`\"$\\& \t{} |()<>]" arg pos))
 302       (push (substring arg pos new-pos) accum)
 303       (push "\\" accum)
 304       (push (list (aref arg new-pos)) accum)
 305       (setq pos (1+ new-pos)))
 306     (if (= pos 0)
 307         arg
 308       (apply 'concat (nconc (nreverse accum) (list (substring arg pos)))))))
 309
 310 (defun mm-auto-mode-alist ()
 311   "Return an `auto-mode-alist' with only the .gz (etc) thingies."
 312   (let ((alist auto-mode-alist)
 313         out)
 314     (while alist
 315       (when (listp (cdar alist))
 316         (push (car alist) out))
 317       (pop alist))
 318     (nreverse out)))
 319
 320 (defun mm-insert-file-contents (filename &optional visit beg end replace)
 321   "Like `insert-file-contents', q.v., but only reads in the file.
 322 A buffer may be modified in several ways after reading into the buffer due
 323 to advanced Emacs features, such as file-name-handlers, format decoding,
 324 find-file-hooks, etc.
 325   This function ensures that none of these modifications will take place."
 326   (let ((format-alist nil)
 327         (auto-mode-alist (mm-auto-mode-alist))
 328         (default-major-mode 'fundamental-mode)
 329         (enable-local-variables nil)
 330         (after-insert-file-functions nil)
 331         (enable-local-eval nil)
 332         (find-file-hooks nil))
 333     (insert-file-contents filename visit beg end replace)))
 334
 335 (provide 'mm-util)
 336
 337 ;;; mm-util.el ends here