X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmm-util.el;h=dfad2a2ad7a502c14f83cfa56d9b0dcf777cb6f9;hb=cddb4672a1b8d0b3fb03dd1c5cad4b01f9fab219;hp=b36c62bcc77687b3150cad7f85fe62d3068e2cd9;hpb=216dd310a007e96604475319ea3087bf9e9970c7;p=elisp%2Fgnus.git- diff --git a/lisp/mm-util.el b/lisp/mm-util.el index b36c62b..dfad2a2 100644 --- a/lisp/mm-util.el +++ b/lisp/mm-util.el @@ -1,5 +1,5 @@ ;;; mm-util.el --- Utility functions for MIME things -;; Copyright (C) 1998 Free Software Foundation, Inc. +;; Copyright (C) 1998,99 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -24,8 +24,27 @@ ;;; Code: -(defvar mm-known-charsets '(iso-8859-1) - "List of known charsets.") +(defvar mm-running-xemacs (string-match "XEmacs" emacs-version)) + +(defvar mm-running-ntemacs + (and (not mm-running-xemacs) + (string-match "nt" system-configuration))) + +(defvar mm-binary-coding-system + (if mm-running-xemacs + 'binary 'no-conversion) + "100% binary coding system.") + +(defvar mm-text-coding-system + (cond + ((not (fboundp 'coding-system-p)) nil) + (mm-running-xemacs ;; XEmacs + 'no-conversion) + (mm-running-ntemacs ;; NTEmacs + (and (coding-system-p 'raw-text-dos) 'raw-text-dos)) + ((coding-system-p 'raw-text) 'raw-text) ;; Emacs + (t nil)) + "100% text coding system, for removing ^M.") (defvar mm-mime-mule-charset-alist '((us-ascii ascii) @@ -39,15 +58,21 @@ (iso-8859-7 greek-iso8859-7) (iso-8859-8 hebrew-iso8859-8) (iso-8859-9 latin-iso8859-9) + (viscii vietnamese-viscii-lower) + (iso-2022-jp-2 japanese-jisx0208) (iso-2022-jp latin-jisx0201 - japanese-jisx0208-1978 japanese-jisx0208) + japanese-jisx0208-1978) (euc-kr korean-ksc5601) (cn-gb-2312 chinese-gb2312) (cn-big5 chinese-big5-1 chinese-big5-2) + (tibetan tibetan) + (thai-tis620 thai-tis620) + (iso-2022-7bit ethiopic arabic-1-column arabic-2-column) (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7 latin-jisx0201 japanese-jisx0208-1978 chinese-gb2312 japanese-jisx0208 - korean-ksc5601 japanese-jisx0212) + korean-ksc5601 japanese-jisx0212 + katakana-jisx0201) (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7 latin-jisx0201 japanese-jisx0208-1978 chinese-gb2312 japanese-jisx0208 @@ -66,59 +91,47 @@ (eval-and-compile - (if (fboundp 'decode-coding-string) - (fset 'mm-decode-coding-string 'decode-coding-string) - (fset 'mm-decode-coding-string (lambda (s a) s))) - - (if (fboundp 'encode-coding-string) - (fset 'mm-encode-coding-string 'encode-coding-string) - (fset 'mm-encode-coding-string (lambda (s a) s))) - - (if (fboundp 'encode-coding-region) - (fset 'mm-encode-coding-region 'encode-coding-region) - (fset 'mm-encode-coding-region 'ignore)) - - (if (fboundp 'decode-coding-region) - (fset 'mm-decode-coding-region 'decode-coding-region) - (fset 'mm-decode-coding-region 'ignore)) - - (if (fboundp 'coding-system-list) - (fset 'mm-coding-system-list 'coding-system-list) - (fset 'mm-coding-system-list 'ignore)) - - (if (fboundp 'char-int) - (fset 'mm-char-int 'char-int) - (fset 'mm-char-int 'identity)) - - (if (fboundp 'coding-system-equal) - (fset 'mm-coding-system-equal 'coding-system-equal) - (fset 'mm-coding-system-equal 'equal)) - - (if (fboundp 'read-coding-system) - (fset 'mm-read-coding-system 'read-coding-system) - (defun mm-read-coding-system (prompt) - "Prompt the user for a coding system." - (completing-read - prompt (mapcar (lambda (s) (list (symbol-name (car s)))) - mm-mime-mule-charset-alist))))) - - -(defvar mm-charset-coding-system-alist - (let ((rest - '((us-ascii . iso-8859-1) - (gb2312 . cn-gb-2312) - (iso-2022-jp-2 . iso-2022-7bit-ss2) - (x-ctext . ctext))) - (systems (mm-coding-system-list)) - dest) - (while rest - (let ((pair (car rest))) - (unless (memq (car pair) systems) - (setq dest (cons pair dest)))) - (setq rest (cdr rest))) - dest) - "Charset/coding system alist.") + (mapcar + (lambda (elem) + (let ((nfunc (intern (format "mm-%s" (car elem))))) + (if (fboundp (car elem)) + (fset nfunc (car elem)) + (fset nfunc (cdr elem))))) + '((decode-coding-string . (lambda (s a) s)) + (encode-coding-string . (lambda (s a) s)) + (encode-coding-region . ignore) + (coding-system-list . ignore) + (decode-coding-region . ignore) + (char-int . identity) + (device-type . ignore) + (coding-system-equal . equal) + (annotationp . ignore) + (set-buffer-file-coding-system . ignore) + (make-char + . (lambda (charset int) + (int-to-char int))) + (read-coding-system + . (lambda (prompt) + "Prompt the user for a coding system." + (completing-read + prompt (mapcar (lambda (s) (list (symbol-name (car s)))) + mm-mime-mule-charset-alist))))))) + +(defvar mm-coding-system-list nil) +(defun mm-get-coding-system-list () + "Get the coding system list." + (or mm-coding-system-list + (setq mm-coding-system-list (mm-coding-system-list)))) +(defvar mm-charset-synonym-alist + '((big5 . cn-big5) + (gb2312 . cn-gb-2312) + (x-ctext . ctext)) + "A mapping from invalid charset names to the real charset names.") + +;;; Internal variables: + +;;; Functions: (defun mm-mule-charset-to-mime-charset (charset) "Return the MIME charset corresponding to MULE CHARSET." @@ -139,17 +152,19 @@ used as the line break code type of the coding system." (when (stringp charset) (setq charset (intern (downcase charset)))) (setq charset - (or (cdr (assq charset mm-charset-coding-system-alist)) + (or (cdr (assq charset mm-charset-synonym-alist)) charset)) (when lbt (setq charset (intern (format "%s-%s" charset lbt)))) (cond ;; Running in a non-MULE environment. - ((and (null (mm-coding-system-list)) - (memq charset mm-known-charsets)) + ((null (mm-get-coding-system-list)) charset) + ;; ascii + ((eq charset 'us-ascii) + 'ascii) ;; Check to see whether we can handle this charset. - ((memq charset (mm-coding-system-list)) + ((memq charset (mm-get-coding-system-list)) charset) ;; Nope. (t @@ -167,23 +182,109 @@ used as the line break code type of the coding system." (setq idx (1+ idx))) string)) -(defun mm-enable-multibyte () +(defsubst mm-enable-multibyte () "Enable multibyte in the current buffer." - (when (fboundp 'set-buffer-multibyte) + (when (and (fboundp 'set-buffer-multibyte) + (default-value 'enable-multibyte-characters)) (set-buffer-multibyte t))) -(defun mm-insert-rfc822-headers (charset encoding) - "Insert text/plain headers with CHARSET and ENCODING." - (insert "MIME-Version: 1.0\n") - (insert "Content-Type: text/plain; charset=\"" - (downcase (symbol-name charset)) "\"\n") - (insert "Content-Transfer-Encoding: " - (downcase (symbol-name encoding)) "\n")) - -(defun mm-content-type-charset (header) - "Return the charset parameter from HEADER." - (when (string-match "charset *= *\"? *\\([-0-9a-zA-Z_]+\\)\"? *$" header) - (intern (downcase (match-string 1 header))))) +(defsubst mm-disable-multibyte () + "Disable multibyte in the current buffer." + (when (fboundp 'set-buffer-multibyte) + (set-buffer-multibyte nil))) + +(defun mm-mime-charset (charset) + "Return the MIME charset corresponding to the MULE CHARSET." + (if (fboundp 'coding-system-get) + ;; This exists in Emacs 20. + (or + (and (get-charset-property charset 'prefered-coding-system) + (coding-system-get + (get-charset-property charset 'prefered-coding-system) + 'mime-charset)) + (and (eq charset 'ascii) + 'us-ascii) + (get-charset-property charset 'prefered-coding-system) + (mm-mule-charset-to-mime-charset charset)) + ;; This is for XEmacs. + (mm-mule-charset-to-mime-charset charset))) + +(defun mm-find-mime-charset-region (b e) + "Return the MIME charsets needed to encode the region between B and E." + (let ((charsets + (mapcar 'mm-mime-charset + (delq 'ascii + (mm-find-charset-region b e))))) + (delete-duplicates charsets))) + +(defsubst mm-multibyte-p () + "Say whether multibyte is enabled." + (and (boundp 'enable-multibyte-characters) + enable-multibyte-characters)) + +(defmacro mm-with-unibyte-buffer (&rest forms) + "Create a temporary buffer, and evaluate FORMS there like `progn'. +See also `with-temp-file' and `with-output-to-string'." + (let ((temp-buffer (make-symbol "temp-buffer")) + (multibyte (make-symbol "multibyte"))) + `(if (not (boundp 'enable-multibyte-characters)) + (with-temp-buffer ,@forms) + (let ((,multibyte (default-value 'enable-multibyte-characters)) + ,temp-buffer) + (unwind-protect + (progn + (setq-default enable-multibyte-characters nil) + (setq ,temp-buffer + (get-buffer-create (generate-new-buffer-name " *temp*"))) + (unwind-protect + (with-current-buffer ,temp-buffer + (let ((buffer-file-coding-system mm-binary-coding-system) + (coding-system-for-read mm-binary-coding-system) + (coding-system-for-write mm-binary-coding-system)) + ,@forms)) + (and (buffer-name ,temp-buffer) + (kill-buffer ,temp-buffer)))) + (setq-default enable-multibyte-characters ,multibyte)))))) +(put 'mm-with-unibyte-buffer 'lisp-indent-function 0) +(put 'mm-with-unibyte-buffer 'edebug-form-spec '(body)) + +(defun mm-find-charset-region (b e) + "Return a list of charsets in the region." + (cond + ((and (boundp 'enable-multibyte-characters) + enable-multibyte-characters + (fboundp 'find-charset-region)) + (find-charset-region b e)) + ((not (boundp 'current-language-environment)) + (save-excursion + (save-restriction + (narrow-to-region b e) + (goto-char (point-min)) + (skip-chars-forward "\0-\177") + (if (eobp) + '(ascii) + (delq nil (list 'ascii mail-parse-charset)))))) + (t + ;; We are in a unibyte buffer, so we futz around a bit. + (save-excursion + (save-restriction + (narrow-to-region b e) + (goto-char (point-min)) + (let ((entry (assoc (capitalize current-language-environment) + language-info-alist))) + (skip-chars-forward "\0-\177") + (if (eobp) + '(ascii) + (list 'ascii (car (last (assq 'charset entry))))))))))) + +(defun mm-read-charset (prompt) + "Return a charset." + (intern + (completing-read + prompt + (mapcar (lambda (e) (list (symbol-name (car e)))) + mm-mime-mule-charset-alist) + nil t))) (provide 'mm-util)