X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmm-util.el;h=543fdf7f3ae61651bf8c63a1338e3db4dd6baee2;hb=ac3b087c73a63e271e40a8e134a345463323e292;hp=fe7c77c4328cf3ae69a0d60493c9549632e0c79d;hpb=0da75afc056452ed77fc820ac865eaaf03fc0952;p=elisp%2Fgnus.git- diff --git a/lisp/mm-util.el b/lisp/mm-util.el index fe7c77c..543fdf7 100644 --- a/lisp/mm-util.el +++ b/lisp/mm-util.el @@ -1,6 +1,7 @@ ;;; mm-util.el --- Utility functions for Mule and low level things -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005 -;; Free Software Foundation, Inc. + +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, +;; 2005 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -18,8 +19,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -57,7 +58,8 @@ mm-mime-mule-charset-alist) nil t)))) (subst-char-in-string - . (lambda (from to string &optional inplace) ;; stolen (and renamed) from nnheader.el + . (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))) @@ -75,6 +77,24 @@ (replace-regexp-in-string regexp rep string nil literal))) (string-as-unibyte . identity) (string-make-unibyte . identity) + ;; string-as-multibyte often doesn't really do what you think it does. + ;; Example: + ;; (aref (string-as-multibyte "\201") 0) -> 129 (aka ?\201) + ;; (aref (string-as-multibyte "\300") 0) -> 192 (aka ?\300) + ;; (aref (string-as-multibyte "\300\201") 0) -> 192 (aka ?\300) + ;; (aref (string-as-multibyte "\300\201") 1) -> 129 (aka ?\201) + ;; but + ;; (aref (string-as-multibyte "\201\300") 0) -> 2240 + ;; (aref (string-as-multibyte "\201\300") 1) -> + ;; Better use string-to-multibyte or encode-coding-string. + ;; If you really need string-as-multibyte somewhere it's usually + ;; because you're using the internal emacs-mule representation (maybe + ;; because you're using string-as-unibyte somewhere), which is + ;; generally a problem in itself. + ;; Here is an approximate equivalence table to help think about it: + ;; (string-as-multibyte s) ~= (decode-coding-string s 'emacs-mule) + ;; (string-to-multibyte s) ~= (decode-coding-string s 'binary) + ;; (string-make-multibyte s) ~= (decode-coding-string s locale-coding-system) (string-as-multibyte . identity) (string-to-multibyte . (lambda (string) @@ -138,13 +158,37 @@ 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) + (and cs (find-coding-system cs)) (if (fboundp 'coding-system-p) (when (coding-system-p cs) cs) ;; Is this branch ever actually useful? (car (memq cs (mm-get-coding-system-list)))))) +(defun mm-codepage-setup (number &optional alias) + "Create a coding system cpNUMBER. +The coding system is created using `codepage-setup'. If ALIAS is +non-nil, an alias is created and added to +`mm-charset-synonym-alist'. If ALIAS is a string, it's used as +the alias. Else windows-NUMBER is used." + (interactive + (let ((completion-ignore-case t) + (candidates (cp-supported-codepages))) + (list (completing-read "Setup DOS Codepage: (default 437) " candidates + nil t nil nil "437")))) + (when alias + (setq alias (if (stringp alias) + (intern alias) + (intern (format "windows-%s" number))))) + (let* ((cp (intern (format "cp%s" number)))) + (unless (mm-coding-system-p cp) + (codepage-setup number)) + (when (and alias + (mm-coding-system-p alias) + ;; Don't add alias if setup of cp failed. + (mm-coding-system-p cp)) + (add-to-list 'mm-charset-synonym-alist (cons alias cp))))) + (defvar mm-charset-synonym-alist `( ;; Not in XEmacs, but it's not a proper MIME charset anyhow. @@ -178,7 +222,51 @@ system object in XEmacs." '((ks_c_5601-1987 . cp949)) '((ks_c_5601-1987 . euc-kr)))) ) - "A mapping from invalid charset names to the real charset names.") + "A mapping from unknown or invalid charset names to the real charset names.") + +(defcustom mm-charset-override-alist + `((iso-8859-1 . windows-1252)) + "A mapping from undesired charset names to their replacement. + +You may add pair like (iso-8859-1 . windows-1252) here, +i.e. treat iso-8859-1 as windows-1252. windows-1252 is a +superset of iso-8859-1." + :type '(list (set :inline t + (const (iso-8859-1 . windows-1252)) + (const (undecided . windows-1252))) + (repeat :inline t + :tag "Other options" + (cons (symbol :tag "From charset") + (symbol :tag "To charset")))) + :version "23.0" ;; No Gnus + :group 'mime) + +(defcustom mm-charset-eval-alist + (if (featurep 'xemacs) + nil ;; I don't know what would be useful for XEmacs. + '(;; Emacs 21 offers 1250 1251 1253 1257. Emacs 22 provides autoloads for + ;; 1250-1258 (i.e. `mm-codepage-setup' does nothing). + (windows-1250 . (mm-codepage-setup 1250 t)) + (windows-1251 . (mm-codepage-setup 1251 t)) + (windows-1253 . (mm-codepage-setup 1253 t)) + (windows-1257 . (mm-codepage-setup 1257 t)))) + "An alist of (CHARSET . FORM) pairs. +If an article is encoded in an unknown CHARSET, FORM is +evaluated. This allows to load additional libraries providing +charsets on demand. If supported by your Emacs version, you +could use `autoload-coding-system' here." + :version "23.0" ;; No Gnus + :type '(list (set :inline t + (const (windows-1250 . (mm-codepage-setup 1250 t))) + (const (windows-1251 . (mm-codepage-setup 1251 t))) + (const (windows-1253 . (mm-codepage-setup 1253 t))) + (const (windows-1257 . (mm-codepage-setup 1257 t))) + (const (cp850 . (mm-codepage-setup 850 nil)))) + (repeat :inline t + :tag "Other options" + (cons (symbol :tag "charset") + (symbol :tag "form")))) + :group 'mime) (defvar mm-binary-coding-system (cond @@ -403,11 +491,17 @@ mail with multiple parts is preferred to sending a Unicode one.") (pop alist)) out))) -(defun mm-charset-to-coding-system (charset &optional lbt) +(defun mm-charset-to-coding-system (charset &optional lbt + allow-override) "Return coding-system corresponding to CHARSET. CHARSET is a symbol naming a MIME charset. If optional argument LBT (`unix', `dos' or `mac') is specified, it is -used as the line break code type of the coding system." +used as the line break code type of the coding system. + +If ALLOW-OVERRIDE is given, use `mm-charset-override-alist' to +map undesired charset names to their replacement. This should +only be used for decoding, not for encoding." + ;; OVERRIDE is used (only) in `mm-decode-body'. (when (stringp charset) (setq charset (intern (downcase charset)))) (when lbt @@ -419,6 +513,11 @@ used as the line break code type of the coding system." ((or (null (mm-get-coding-system-list)) (not (fboundp 'coding-system-get))) charset) + ;; Check override list quite early. Should only used for decoding, not for + ;; encoding! + ((and allow-override + (let ((cs (cdr (assq charset mm-charset-override-alist)))) + (and cs (mm-coding-system-p cs) cs)))) ;; ascii ((eq charset 'us-ascii) 'ascii) @@ -431,9 +530,27 @@ used as the line break code type of the coding system." ;;; (eq charset (coding-system-get charset 'mime-charset)) ) charset) + ;; Eval expressions from `mm-charset-eval-alist' + ((let* ((el (assq charset mm-charset-eval-alist)) + (cs (car el)) + (form (cdr el))) + (and cs + form + (prog2 + ;; Avoid errors... + (condition-case nil (eval form) (error nil)) + ;; (message "Failed to eval `%s'" form)) + (mm-coding-system-p cs) + (message "Added charset `%s' via `mm-charset-eval-alist'" cs)) + cs))) ;; Translate invalid charsets. ((let ((cs (cdr (assq charset mm-charset-synonym-alist)))) - (and cs (mm-coding-system-p cs) cs))) + (and cs + (mm-coding-system-p cs) + ;; (message + ;; "Using synonym `%s' from `mm-charset-synonym-alist' for `%s'" + ;; cs charset) + cs))) ;; Last resort: search the coding system list for entries which ;; have the right mime-charset in case the canonical name isn't ;; defined (though it should be). @@ -445,6 +562,11 @@ used as the line break code type of the coding system." (eq charset (or (coding-system-get c :mime-charset) (coding-system-get c 'mime-charset)))) (setq cs c))) + (unless cs + ;; Warn the user about unknown charset: + (if (fboundp 'gnus-message) + (gnus-message 7 "Unknown charset: %s" charset) + (message "Unknown charset: %s" charset))) cs)))) (eval-and-compile @@ -532,14 +654,21 @@ If the charset is `composition', return the actual one." ;; This is for XEmacs. (mm-mule-charset-to-mime-charset charset))) -(defun mm-delete-duplicates (list) - "Simple substitute for CL `delete-duplicates', testing with `equal'." - (let (result head) - (while list - (setq head (car list)) - (setq list (delete head list)) - (setq result (cons head result))) - (nreverse result))) +(if (fboundp 'delete-dups) + (defalias 'mm-delete-duplicates 'delete-dups) + (defun mm-delete-duplicates (list) + "Destructively remove `equal' duplicates from LIST. +Store the result in LIST and return it. LIST must be a proper list. +Of several `equal' occurrences of an element in LIST, the first +one is kept. + +This is a compatibility function for Emacsen without `delete-dups'." + ;; Code from `subr.el' in Emacs 22: + (let ((tail list)) + (while tail + (setcdr tail (delete (car tail) (cdr tail))) + (setq tail (cdr tail)))) + list)) ;; Fixme: This is used in places when it should be testing the ;; default multibyteness. See mm-default-multibyte-p. @@ -668,7 +797,7 @@ But this is very much a corner case, so don't worry about it." (defmacro mm-xemacs-find-mime-charset (begin end) (when (featurep 'xemacs) - `(mm-xemacs-find-mime-charset-1 ,begin ,end))) + `(and (featurep 'mule) (mm-xemacs-find-mime-charset-1 ,begin ,end)))) (defun mm-find-mime-charset-region (b e &optional hack-charsets) "Return the MIME charsets needed to encode the region between B and E. @@ -731,6 +860,17 @@ charset, and a longer list means no appropriate charset." (if (and (memq 'iso-2022-jp-2 charsets) (memq 'iso-2022-jp-2 hack-charsets)) (setq charsets (delq 'iso-2022-jp charsets))) + ;; Attempt to reduce the number of charsets if utf-8 is available. + (if (and (featurep 'xemacs) + (> (length charsets) 1) + (mm-coding-system-p 'utf-8)) + (let ((mm-coding-system-priorities + (cons 'utf-8 mm-coding-system-priorities))) + (setq charsets + (mm-delete-duplicates + (mapcar 'mm-mime-charset + (delq 'ascii + (mm-find-charset-region b e))))))) charsets)) (defmacro mm-with-unibyte-buffer (&rest forms) @@ -839,22 +979,28 @@ to advanced Emacs features, such as file-name-handlers, format decoding, `find-file-hooks', etc. If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'. This function ensures that none of these modifications will take place." - (let ((format-alist nil) - (auto-mode-alist (if inhibit nil (mm-auto-mode-alist))) - (default-major-mode 'fundamental-mode) - (enable-local-variables nil) - (after-insert-file-functions nil) - (enable-local-eval nil) - (find-file-hooks nil) - (inhibit-file-name-operation (if inhibit - 'insert-file-contents - inhibit-file-name-operation)) - (inhibit-file-name-handlers - (if inhibit - (append mm-inhibit-file-name-handlers - inhibit-file-name-handlers) - inhibit-file-name-handlers))) - (insert-file-contents filename visit beg end replace))) + (let* ((format-alist nil) + (auto-mode-alist (if inhibit nil (mm-auto-mode-alist))) + (default-major-mode 'fundamental-mode) + (enable-local-variables nil) + (after-insert-file-functions nil) + (enable-local-eval nil) + (inhibit-file-name-operation (if inhibit + 'insert-file-contents + inhibit-file-name-operation)) + (inhibit-file-name-handlers + (if inhibit + (append mm-inhibit-file-name-handlers + inhibit-file-name-handlers) + inhibit-file-name-handlers)) + (ffh (if (boundp 'find-file-hook) + 'find-file-hook + 'find-file-hooks)) + (val (symbol-value ffh))) + (set ffh nil) + (unwind-protect + (insert-file-contents filename visit beg end replace) + (set ffh val)))) (defun mm-append-to-file (start end filename &optional codesys inhibit) "Append the contents of the region to the end of file FILENAME. @@ -912,7 +1058,7 @@ If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'." (defun mm-detect-coding-region (start end) "Like `detect-coding-region' except returning the best one." (let ((coding-systems - (detect-coding-region (point) (point-max)))) + (detect-coding-region start end))) (or (car-safe coding-systems) coding-systems))) (defun mm-detect-coding-region (start end) @@ -1040,7 +1186,12 @@ gzip, bzip2, etc. are allowed." (unless filename (setq filename buffer-file-name)) (save-excursion - (let ((decomp (mm-decompress-buffer filename nil t))) + (let ((decomp (unless ;; No worth to examine charset of tar files. + (and filename + (string-match + "\\.\\(?:tar\\.[^.]+\\|tbz\\|tgz\\)\\'" + filename)) + (mm-decompress-buffer filename nil t)))) (when decomp (set-buffer (let (default-enable-multibyte-characters) (generate-new-buffer " *temp*")))