;;; mm-util.el --- Utility functions for Mule and low level things
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;;; Code:
-(eval-when-compile (require 'cl))
-(eval-when-compile (require 'gnus-clfns))
-(eval-when-compile (require 'static))
+(eval-when-compile
+ (require 'cl)
+ (require 'static))
(require 'mail-prsvr)
(coding-system-equal . equal)
(annotationp . ignore)
(set-buffer-file-coding-system . ignore)
- (make-char
- . (lambda (charset int)
- (int-to-char int)))
(read-charset
. (lambda (prompt)
"Return a charset."
mm-mime-mule-charset-alist)
nil t))))
(subst-char-in-string
- . (lambda (from to string) ;; stolen (and renamed) from nnheader.el
- "Replace characters in STRING from FROM to TO."
- (let ((string (substring string 0)) ;Copy string.
+ . (lambda (from to string &optional inplace) ;; stolen (and renamed) from nnheader.el
+ "Replace characters in STRING from FROM to TO.
+ Unless optional argument INPLACE is non-nil, return a new string."
+ (let ((string (if inplace string (copy-sequence string)))
(len (length string))
(idx 0))
;; Replace all occurrences of FROM with TO.
(aset string idx to))
(setq idx (1+ idx)))
string)))
+ (replace-in-string
+ . (lambda (string regexp rep &optional literal)
+ "See `replace-regexp-in-string', only the order of args differs."
+ (replace-regexp-in-string regexp rep string nil literal)))
(string-as-unibyte . identity)
(string-make-unibyte . identity)
(string-as-multibyte . identity)
(defun mm-coding-system-p (cs)
"Return non-nil if CS is a symbol naming a coding system.
-In XEmacs, also return non-nil if CS is a coding system object."
+In XEmacs, also return non-nil if CS is a coding system object.
+If CS is available, return CS itself in Emacs, and return a coding
+system object in XEmacs."
(if (fboundp 'find-coding-system)
(find-coding-system cs)
(if (fboundp 'coding-system-p)
- (coding-system-p cs)
+ (when (coding-system-p cs)
+ cs)
;; Is this branch ever actually useful?
- (memq cs (mm-get-coding-system-list)))))
+ (car (memq cs (mm-get-coding-system-list))))))
(defvar mm-charset-synonym-alist
`(
- ;; Perfectly fine? A valid MIME name, anyhow.
- ,@(unless (mm-coding-system-p 'big5)
- '((big5 . cn-big5)))
;; Not in XEmacs, but it's not a proper MIME charset anyhow.
,@(unless (mm-coding-system-p 'x-ctext)
'((x-ctext . ctext)))
- ;; Apparently not defined in Emacs 20, but is a valid MIME name.
- ,@(unless (mm-coding-system-p 'gb2312)
- '((gb2312 . cn-gb-2312)))
;; ISO-8859-15 is very similar to ISO-8859-1. But it's _different_!
,@(unless (mm-coding-system-p 'iso-8859-15)
'((iso-8859-15 . iso-8859-1)))
,@(if (and (not (mm-coding-system-p 'windows-1250))
(mm-coding-system-p 'cp1250))
'((windows-1250 . cp1250)))
+ ;; A Microsoft misunderstanding.
+ ,@(if (and (not (mm-coding-system-p 'unicode))
+ (mm-coding-system-p 'utf-16-le))
+ '((unicode . utf-16-le)))
+ ;; A Microsoft misunderstanding.
+ ,@(unless (mm-coding-system-p 'ks_c_5601-1987)
+ (if (mm-coding-system-p 'cp949)
+ '((ks_c_5601-1987 . cp949))
+ '((ks_c_5601-1987 . euc-kr))))
)
"A mapping from invalid charset names to the real charset names.")
(big5 chinese-big5-1 chinese-big5-2)
(tibetan tibetan)
(thai-tis620 thai-tis620)
+ (windows-1251 cyrillic-iso8859-5)
(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
- katakana-jisx0201)
+ korean-ksc5601 japanese-jisx0212)
(iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
latin-jisx0201 japanese-jisx0208-1978
chinese-gb2312 japanese-jisx0208
chinese-cns11643-3 chinese-cns11643-4
chinese-cns11643-5 chinese-cns11643-6
chinese-cns11643-7)
+ (iso-2022-jp-3 latin-jisx0201 japanese-jisx0208-1978 japanese-jisx0208
+ japanese-jisx0213-1 japanese-jisx0213-2)
+ (shift_jis latin-jisx0201 katakana-jisx0201 japanese-jisx0208)
,(if (or (not (fboundp 'charsetp)) ;; non-Mule case
(charsetp 'unicode-a)
(not (mm-coding-system-p 'mule-utf-8)))
(coding-system-get 'mule-utf-8 'safe-charsets)))))
"Alist of MIME-charset/MULE-charsets.")
-;; Correct by construction, but should be unnecessary:
-;; XEmacs hates it.
-(when (and (not (featurep 'xemacs))
- (fboundp 'coding-system-list)
- (fboundp 'sort-coding-systems))
- (setq mm-mime-mule-charset-alist
- (apply
- 'nconc
- (mapcar
- (lambda (cs)
- (when (and (or (coding-system-get cs :mime-charset) ; Emacs 22
- (coding-system-get cs 'mime-charset))
- (not (eq t (coding-system-get cs 'safe-charsets))))
- (list (cons (or (coding-system-get cs :mime-charset)
- (coding-system-get cs 'mime-charset))
- (delq 'ascii
- (coding-system-get cs 'safe-charsets))))))
- (sort-coding-systems (coding-system-list 'base-only))))))
+(defun mm-enrich-utf-8-by-mule-ucs ()
+ "Make the `utf-8' MIME charset usable by the Mule-UCS package.
+This function will run when the `un-define' module is loaded under
+XEmacs, and fill the `utf-8' entry in `mm-mime-mule-charset-alist'
+with Mule charsets. It is completely useless for Emacs."
+ (unless (cdr (delete '(mm-enrich-utf-8-by-mule-ucs)
+ (assoc "un-define" after-load-alist)))
+ (setq after-load-alist
+ (delete '("un-define") after-load-alist)))
+ (when (boundp 'unicode-basic-translation-charset-order-list)
+ (condition-case nil
+ (let ((val (delq
+ 'ascii
+ (copy-sequence
+ (symbol-value
+ 'unicode-basic-translation-charset-order-list))))
+ (elem (assq 'utf-8 mm-mime-mule-charset-alist)))
+ (if elem
+ (setcdr elem val)
+ (setq mm-mime-mule-charset-alist
+ (nconc mm-mime-mule-charset-alist
+ (list (cons 'utf-8 val))))))
+ (error))))
+
+;; Correct by construction, but should be unnecessary for Emacs:
+(if (featurep 'xemacs)
+ (eval-after-load "un-define" '(mm-enrich-utf-8-by-mule-ucs))
+ (when (and (fboundp 'coding-system-list)
+ (fboundp 'sort-coding-systems))
+ (let ((css (sort-coding-systems (coding-system-list 'base-only)))
+ cs mime mule alist)
+ (while css
+ (setq cs (pop css)
+ mime (or (coding-system-get cs :mime-charset) ; Emacs 22
+ (coding-system-get cs 'mime-charset)))
+ (when (and mime
+ (not (eq t (setq mule
+ (coding-system-get cs 'safe-charsets))))
+ (not (assq mime alist)))
+ (push (cons mime (delq 'ascii mule)) alist)))
+ (setq mm-mime-mule-charset-alist (nreverse alist)))))
(defvar mm-hack-charsets '(iso-8859-15 iso-2022-jp-2)
"A list of special charsets.
(if (boundp 'current-language-environment)
(let ((lang (symbol-value 'current-language-environment)))
(cond ((string= lang "Japanese")
- ;; Japanese users may prefer iso-2022-jp to shift-jis.
- '(iso-2022-jp iso-2022-jp-2 japanese-shift-jis
- iso-latin-1 utf-8)))))
+ ;; Japanese users may prefer iso-2022-jp to shift_jis.
+ '(iso-2022-jp iso-2022-jp-2 shift_jis iso-8859-1 utf-8)))))
"Preferred coding systems for encoding outgoing messages.
More than one suitable coding system may be found for some text.
By default, the coding system with the highest priority is used
to encode outgoing messages (see `sort-coding-systems'). If this
variable is set, it overrides the default priority."
+ :version "21.2"
:type '(repeat (symbol :tag "Coding system"))
:group 'mime)
"Return the MIME charset corresponding to the given Mule CHARSET."
(if (and (fboundp 'find-coding-systems-for-charsets)
(fboundp 'sort-coding-systems))
- (let (mime)
- (dolist (cs (sort-coding-systems
- (copy-sequence
- (find-coding-systems-for-charsets (list charset)))))
- (unless mime
- (when cs
- (setq mime (or (coding-system-get cs :mime-charset)
- (coding-system-get cs 'mime-charset))))))
+ (let ((css (sort (sort-coding-systems
+ (find-coding-systems-for-charsets (list charset)))
+ 'mm-sort-coding-systems-predicate))
+ cs mime)
+ (while (and (not mime)
+ css)
+ (when (setq cs (pop css))
+ (setq mime (or (coding-system-get cs :mime-charset)
+ (coding-system-get cs 'mime-charset)))))
mime)
- (let ((alist mm-mime-mule-charset-alist)
+ (let ((alist (mapcar (lambda (cs)
+ (assq cs mm-mime-mule-charset-alist))
+ (sort (mapcar 'car mm-mime-mule-charset-alist)
+ 'mm-sort-coding-systems-predicate)))
out)
(while alist
(when (memq charset (cdar alist))
(setq cs c)))
cs))))
-(defsubst mm-replace-chars-in-string (string from to)
- (mm-subst-char-in-string from to string))
-
(eval-and-compile
(defvar mm-emacs-mule (and (not (featurep 'xemacs))
(boundp 'default-enable-multibyte-characters)
(let ((priorities
(mapcar (lambda (cs)
;; Note: invalid entries are dropped silently
- (and (coding-system-p cs)
+ (and (setq cs (mm-coding-system-p cs))
(coding-system-base cs)))
mm-coding-system-priorities)))
- (> (length (memq a priorities))
- (length (memq b priorities)))))
+ (and (setq a (mm-coding-system-p a))
+ (if (setq b (mm-coding-system-p b))
+ (> (length (memq (coding-system-base a) priorities))
+ (length (memq (coding-system-base b) priorities)))
+ t))))
(defun mm-find-mime-charset-region (b e &optional hack-charsets)
"Return the MIME charsets needed to encode the region between B and E.
(put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
(put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
+(defmacro mm-with-multibyte-buffer (&rest forms)
+ "Create a temporary buffer, and evaluate FORMS there like `progn'.
+Use multibyte mode for this."
+ `(let ((default-enable-multibyte-characters t))
+ (with-temp-buffer ,@forms)))
+(put 'mm-with-multibyte-buffer 'lisp-indent-function 0)
+(put 'mm-with-multibyte-buffer 'edebug-form-spec '(body))
+
(defmacro mm-with-unibyte-current-buffer (&rest forms)
"Evaluate FORMS with current buffer temporarily made unibyte.
Also bind `default-enable-multibyte-characters' to nil.
(put 'mm-with-unibyte-current-buffer 'edebug-form-spec '(body))
(defmacro mm-with-unibyte (&rest forms)
- "Eval the FORMS with the default value of `enable-multibyte-characters' nil, ."
+ "Eval the FORMS with the default value of `enable-multibyte-characters' nil."
`(let (default-enable-multibyte-characters)
,@forms))
(put 'mm-with-unibyte 'lisp-indent-function 0)
(put 'mm-with-unibyte 'edebug-form-spec '(body))
+(defmacro mm-with-multibyte (&rest forms)
+ "Eval the FORMS with the default value of `enable-multibyte-characters' t."
+ `(let ((default-enable-multibyte-characters t))
+ ,@forms))
+(put 'mm-with-multibyte 'lisp-indent-function 0)
+(put 'mm-with-multibyte 'edebug-form-spec '(body))
+
(defun mm-find-charset-region (b e)
"Return a list of Emacs charsets in the region B to E."
(cond
mm-mime-mule-charset-alist)))))
(list 'ascii (or charset 'latin-iso8859-1)))))))))
-(static-if (fboundp 'shell-quote-argument)
- (defalias 'mm-quote-arg 'shell-quote-argument)
- (defun mm-quote-arg (arg)
- "Return a version of ARG that is safe to evaluate in a shell."
- (let ((pos 0) new-pos accum)
- ;; *** bug: we don't handle newline characters properly
- (while (setq new-pos (string-match "[]*[;!'`\"$\\& \t{} |()<>]" arg pos))
- (push (substring arg pos new-pos) accum)
- (push "\\" accum)
- (push (list (aref arg new-pos)) accum)
- (setq pos (1+ new-pos)))
- (if (= pos 0)
- arg
- (apply 'concat (nconc (nreverse accum) (list (substring arg pos))))))))
-
(defun mm-auto-mode-alist ()
"Return an `auto-mode-alist' with only the .gz (etc) thingies."
(let ((alist auto-mode-alist)
(defun mm-image-load-path (&optional package)
(let (dir result)
(dolist (path load-path (nreverse result))
- (if (file-directory-p
- (setq dir (concat (file-name-directory
- (directory-file-name path))
- "etc/" (or package "gnus/"))))
- (push dir result))
+ (when (and path
+ (file-directory-p
+ (setq dir (concat (file-name-directory
+ (directory-file-name path))
+ "etc/" (or package "gnus/")))))
+ (push dir result))
(push path result))))
;; Fixme: This doesn't look useful where it's used.
projects / elisp / gnus.git- / blobdiff