cgit.sxemacs.org Git - gnus/blob - lisp/mm-util.el

   1 ;;; mm-util.el --- Utility functions for Mule and low level things
   2
   3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
   4 ;;   2007, 2008, 2009, 2010  Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 ;; For Emacs <22.2 and XEmacs.
  28 (eval-and-compile
  29   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
  30
  31 (eval-when-compile (require 'cl))
  32 (require 'mail-prsvr)
  33
  34 (eval-and-compile
  35   (if (featurep 'xemacs)
  36       (unless (ignore-errors
  37                 (require 'timer-funcs))
  38         (require 'timer))
  39     (require 'timer)))
  40
  41 (defvar mm-mime-mule-charset-alist )
  42 ;; Note this is not presently used on Emacs >= 23, which is good,
  43 ;; since it means standalone message-mode (which requires mml and
  44 ;; hence mml-util) does not load gnus-util.
  45 (autoload 'gnus-completing-read "gnus-util")
  46
  47 ;; Emulate functions that are not available in every (X)Emacs version.
  48 ;; The name of a function is prefixed with mm-, like `mm-char-int' for
  49 ;; `char-int' that is a native XEmacs function, not available in Emacs.
  50 ;; Gnus programs all should use mm- functions, not the original ones.
  51 (eval-and-compile
  52   (mapc
  53    (lambda (elem)
  54      (let ((nfunc (intern (format "mm-%s" (car elem)))))
  55        (if (fboundp (car elem))
  56            (defalias nfunc (car elem))
  57          (defalias nfunc (cdr elem)))))
  58    `(;; `coding-system-list' is not available in XEmacs 21.4 built
  59      ;; without the `file-coding' feature.
  60      (coding-system-list . ignore)
  61      ;; `char-int' is an XEmacs function, not available in Emacs.
  62      (char-int . identity)
  63      ;; `coding-system-equal' is an Emacs function, not available in XEmacs.
  64      (coding-system-equal . equal)
  65      ;; `annotationp' is an XEmacs function, not available in Emacs.
  66      (annotationp . ignore)
  67      ;; `set-buffer-file-coding-system' is not available in XEmacs 21.4
  68      ;; built without the `file-coding' feature.
  69      (set-buffer-file-coding-system . ignore)
  70      ;; `read-charset' is an Emacs function, not available in XEmacs.
  71      (read-charset
  72       . ,(lambda (prompt)
  73            "Return a charset."
  74            (intern
  75             (gnus-completing-read
  76              prompt
  77              (mapcar (lambda (e) (symbol-name (car e)))
  78                      mm-mime-mule-charset-alist)
  79              t))))
  80      ;; `subst-char-in-string' is not available in XEmacs 21.4.
  81      (subst-char-in-string
  82       . ,(lambda (from to string &optional inplace)
  83            ;; stolen (and renamed) from nnheader.el
  84            "Replace characters in STRING from FROM to TO.
  85           Unless optional argument INPLACE is non-nil, return a new string."
  86            (let ((string (if inplace string (copy-sequence string)))
  87                  (len (length string))
  88                  (idx 0))
  89              ;; Replace all occurrences of FROM with TO.
  90              (while (< idx len)
  91                (when (= (aref string idx) from)
  92                  (aset string idx to))
  93                (setq idx (1+ idx)))
  94              string)))
  95      ;; `replace-in-string' is an XEmacs function, not available in Emacs.
  96      (replace-in-string
  97       . ,(lambda (string regexp rep &optional literal)
  98            "See `replace-regexp-in-string', only the order of args differs."
  99            (replace-regexp-in-string regexp rep string nil literal)))
 100      ;; `string-as-unibyte' is an Emacs function, not available in XEmacs.
 101      (string-as-unibyte . identity)
 102      ;; `string-make-unibyte' is an Emacs function, not available in XEmacs.
 103      (string-make-unibyte . identity)
 104      ;; string-as-multibyte often doesn't really do what you think it does.
 105      ;; Example:
 106      ;;    (aref (string-as-multibyte "\201") 0) -> 129 (aka ?\201)
 107      ;;    (aref (string-as-multibyte "\300") 0) -> 192 (aka ?\300)
 108      ;;    (aref (string-as-multibyte "\300\201") 0) -> 192 (aka ?\300)
 109      ;;    (aref (string-as-multibyte "\300\201") 1) -> 129 (aka ?\201)
 110      ;; but
 111      ;;    (aref (string-as-multibyte "\201\300") 0) -> 2240
 112      ;;    (aref (string-as-multibyte "\201\300") 1) -> <error>
 113      ;; Better use string-to-multibyte or encode-coding-string.
 114      ;; If you really need string-as-multibyte somewhere it's usually
 115      ;; because you're using the internal emacs-mule representation (maybe
 116      ;; because you're using string-as-unibyte somewhere), which is
 117      ;; generally a problem in itself.
 118      ;; Here is an approximate equivalence table to help think about it:
 119      ;; (string-as-multibyte s)   ~= (decode-coding-string s 'emacs-mule)
 120      ;; (string-to-multibyte s)   ~= (decode-coding-string s 'binary)
 121      ;; (string-make-multibyte s) ~= (decode-coding-string s locale-coding-system)
 122      ;; `string-as-multibyte' is an Emacs function, not available in XEmacs.
 123      (string-as-multibyte . identity)
 124      ;; `multibyte-string-p' is an Emacs function, not available in XEmacs.
 125      (multibyte-string-p . ignore)
 126      ;; `insert-byte' is available only in Emacs 23.1 or greater.
 127      (insert-byte . insert-char)
 128      ;; `multibyte-char-to-unibyte' is an Emacs function, not available
 129      ;; in XEmacs.
 130      (multibyte-char-to-unibyte . identity)
 131      ;; `set-buffer-multibyte' is an Emacs function, not available in XEmacs.
 132      (set-buffer-multibyte . ignore)
 133      ;; `special-display-p' is an Emacs function, not available in XEmacs.
 134      (special-display-p
 135       . ,(lambda (buffer-name)
 136            "Returns non-nil if a buffer named BUFFER-NAME gets a special frame."
 137            (and special-display-function
 138                 (or (and (member buffer-name special-display-buffer-names) t)
 139                     (cdr (assoc buffer-name special-display-buffer-names))
 140                     (catch 'return
 141                       (dolist (elem special-display-regexps)
 142                         (and (stringp elem)
 143                              (string-match elem buffer-name)
 144                              (throw 'return t))
 145                         (and (consp elem)
 146                              (stringp (car elem))
 147                              (string-match (car elem) buffer-name)
 148                              (throw 'return (cdr elem)))))))))
 149      ;; `substring-no-properties' is available only in Emacs 22.1 or greater.
 150      (substring-no-properties
 151       . ,(lambda (string &optional from to)
 152            "Return a substring of STRING, without text properties.
 153 It starts at index FROM and ending before TO.
 154 TO may be nil or omitted; then the substring runs to the end of STRING.
 155 If FROM is nil or omitted, the substring starts at the beginning of STRING.
 156 If FROM or TO is negative, it counts from the end.
 157
 158 With one argument, just copy STRING without its properties."
 159            (setq string (substring string (or from 0) to))
 160            (set-text-properties 0 (length string) nil string)
 161            string))
 162      ;; `line-number-at-pos' is available only in Emacs 22.1 or greater
 163      ;; and XEmacs 21.5.
 164      (line-number-at-pos
 165       . ,(lambda (&optional pos)
 166            "Return (narrowed) buffer line number at position POS.
 167 If POS is nil, use current buffer location.
 168 Counting starts at (point-min), so the value refers
 169 to the contents of the accessible portion of the buffer."
 170            (let ((opoint (or pos (point))) start)
 171              (save-excursion
 172                (goto-char (point-min))
 173                (setq start (point))
 174                (goto-char opoint)
 175                (forward-line 0)
 176                (1+ (count-lines start (point))))))))))
 177
 178 ;; `decode-coding-string', `encode-coding-string', `decode-coding-region'
 179 ;; and `encode-coding-region' are available in Emacs and XEmacs built with
 180 ;; the `file-coding' feature, but the XEmacs versions treat nil, that is
 181 ;; given as the `coding-system' argument, as the `binary' coding system.
 182 (eval-and-compile
 183   (if (featurep 'xemacs)
 184       (if (featurep 'file-coding)
 185           (progn
 186             (defun mm-decode-coding-string (str coding-system)
 187               (if coding-system
 188                   (decode-coding-string str coding-system)
 189                 str))
 190             (defun mm-encode-coding-string (str coding-system)
 191               (if coding-system
 192                   (encode-coding-string str coding-system)
 193                 str))
 194             (defun mm-decode-coding-region (start end coding-system)
 195               (if coding-system
 196                   (decode-coding-region start end coding-system)))
 197             (defun mm-encode-coding-region (start end coding-system)
 198               (if coding-system
 199                   (encode-coding-region start end coding-system))))
 200         (defun mm-decode-coding-string (str coding-system) str)
 201         (defun mm-encode-coding-string (str coding-system) str)
 202         (defalias 'mm-decode-coding-region 'ignore)
 203         (defalias 'mm-encode-coding-region 'ignore))
 204     (defalias 'mm-decode-coding-string 'decode-coding-string)
 205     (defalias 'mm-encode-coding-string 'encode-coding-string)
 206     (defalias 'mm-decode-coding-region 'decode-coding-region)
 207     (defalias 'mm-encode-coding-region 'encode-coding-region)))
 208
 209 ;; `string-to-multibyte' is available only in Emacs.
 210 (defalias 'mm-string-to-multibyte (if (featurep 'xemacs)
 211                                       'identity
 212                                     'string-to-multibyte))
 213
 214 ;; `char-or-char-int-p' is an XEmacs function, not available in Emacs.
 215 (eval-and-compile
 216   (defalias 'mm-char-or-char-int-p
 217     (cond
 218      ((fboundp 'char-or-char-int-p) 'char-or-char-int-p)
 219      ((fboundp 'char-valid-p) 'char-valid-p)
 220      (t 'identity))))
 221
 222 ;; `ucs-to-char' is a function that Mule-UCS provides.
 223 (if (featurep 'xemacs)
 224     (cond ((and (fboundp 'unicode-to-char) ;; XEmacs 21.5.
 225                 (subrp (symbol-function 'unicode-to-char)))
 226            (if (featurep 'mule)
 227                (defalias 'mm-ucs-to-char 'unicode-to-char)
 228              (defun mm-ucs-to-char (codepoint)
 229                "Convert Unicode codepoint to character."
 230                (or (unicode-to-char codepoint) ?#))))
 231           ((featurep 'mule)
 232            (defun mm-ucs-to-char (codepoint)
 233              "Convert Unicode codepoint to character."
 234              (if (fboundp 'ucs-to-char) ;; Mule-UCS is loaded.
 235                  (progn
 236                    (defalias 'mm-ucs-to-char
 237                      (lambda (codepoint)
 238                        "Convert Unicode codepoint to character."
 239                        (condition-case nil
 240                            (or (ucs-to-char codepoint) ?#)
 241                          (error ?#))))
 242                    (mm-ucs-to-char codepoint))
 243                (condition-case nil
 244                    (or (int-to-char codepoint) ?#)
 245                  (error ?#)))))
 246           (t
 247            (defun mm-ucs-to-char (codepoint)
 248              "Convert Unicode codepoint to character."
 249              (condition-case nil
 250                  (or (int-to-char codepoint) ?#)
 251                (error ?#)))))
 252   (if (let ((char (make-char 'japanese-jisx0208 36 34)))
 253         (eq char (decode-char 'ucs char)))
 254       ;; Emacs 23.
 255       (defalias 'mm-ucs-to-char 'identity)
 256     (defun mm-ucs-to-char (codepoint)
 257       "Convert Unicode codepoint to character."
 258       (or (decode-char 'ucs codepoint) ?#))))
 259
 260 ;; Fixme:  This seems always to be used to read a MIME charset, so it
 261 ;; should be re-named and fixed (in Emacs) to offer completion only on
 262 ;; proper charset names (base coding systems which have a
 263 ;; mime-charset defined).  XEmacs doesn't believe in mime-charset;
 264 ;; test with
 265 ;;   `(or (coding-system-get 'iso-8859-1 'mime-charset)
 266 ;;        (coding-system-get 'iso-8859-1 :mime-charset))'
 267 ;; Actually, there should be an `mm-coding-system-mime-charset'.
 268 (eval-and-compile
 269   (defalias 'mm-read-coding-system
 270     (if (featurep 'emacs) 'read-coding-system
 271       (cond
 272        ((fboundp 'read-coding-system)
 273         (if (and (featurep 'xemacs)
 274                  (<= (string-to-number emacs-version) 21.1))
 275             (lambda (prompt &optional default-coding-system)
 276               (read-coding-system prompt))
 277           'read-coding-system))
 278        (t (lambda (prompt &optional default-coding-system)
 279             "Prompt the user for a coding system."
 280             (gnus-completing-read
 281              prompt (mapcar (lambda (s) (symbol-name (car s)))
 282                             mm-mime-mule-charset-alist))))))))
 283
 284 (defvar mm-coding-system-list nil)
 285 (defun mm-get-coding-system-list ()
 286   "Get the coding system list."
 287   (or mm-coding-system-list
 288       (setq mm-coding-system-list (mm-coding-system-list))))
 289
 290 (defun mm-coding-system-p (cs)
 291   "Return non-nil if CS is a symbol naming a coding system.
 292 In XEmacs, also return non-nil if CS is a coding system object.
 293 If CS is available, return CS itself in Emacs, and return a coding
 294 system object in XEmacs."
 295   (if (fboundp 'find-coding-system)
 296       (and cs (find-coding-system cs))
 297     (if (fboundp 'coding-system-p)
 298         (when (coding-system-p cs)
 299           cs)
 300       ;; no-MULE XEmacs:
 301       (car (memq cs (mm-get-coding-system-list))))))
 302
 303 (defun mm-codepage-setup (number &optional alias)
 304   "Create a coding system cpNUMBER.
 305 The coding system is created using `codepage-setup'.  If ALIAS is
 306 non-nil, an alias is created and added to
 307 `mm-charset-synonym-alist'.  If ALIAS is a string, it's used as
 308 the alias.  Else windows-NUMBER is used."
 309   (interactive
 310    (let ((completion-ignore-case t)
 311          (candidates (if (fboundp 'cp-supported-codepages)
 312                          (cp-supported-codepages)
 313                        ;; Removed in Emacs 23 (unicode), so signal an error:
 314                        (error "`codepage-setup' not present in this Emacs version"))))
 315      (list (gnus-completing-read "Setup DOS Codepage" candidates
 316                                  t nil nil "437"))))
 317   (when alias
 318     (setq alias (if (stringp alias)
 319                     (intern alias)
 320                   (intern (format "windows-%s" number)))))
 321   (let* ((cp (intern (format "cp%s" number))))
 322     (unless (mm-coding-system-p cp)
 323       (if (fboundp 'codepage-setup)     ; silence compiler
 324           (codepage-setup number)
 325         (error "`codepage-setup' not present in this Emacs version")))
 326     (when (and alias
 327                ;; Don't add alias if setup of cp failed.
 328                (mm-coding-system-p cp))
 329       (add-to-list 'mm-charset-synonym-alist (cons alias cp)))))
 330
 331 (defvar mm-charset-synonym-alist
 332   `(
 333     ;; Not in XEmacs, but it's not a proper MIME charset anyhow.
 334     ,@(unless (mm-coding-system-p 'x-ctext)
 335         '((x-ctext . ctext)))
 336     ;; ISO-8859-15 is very similar to ISO-8859-1.  But it's _different_ in 8
 337     ;; positions!
 338     ,@(unless (mm-coding-system-p 'iso-8859-15)
 339         '((iso-8859-15 . iso-8859-1)))
 340     ;; BIG-5HKSCS is similar to, but different than, BIG-5.
 341     ,@(unless (mm-coding-system-p 'big5-hkscs)
 342         '((big5-hkscs . big5)))
 343     ;; A Microsoft misunderstanding.
 344     ,@(when (and (not (mm-coding-system-p 'unicode))
 345                  (mm-coding-system-p 'utf-16-le))
 346         '((unicode . utf-16-le)))
 347     ;; A Microsoft misunderstanding.
 348     ,@(unless (mm-coding-system-p 'ks_c_5601-1987)
 349         (if (mm-coding-system-p 'cp949)
 350             '((ks_c_5601-1987 . cp949))
 351           '((ks_c_5601-1987 . euc-kr))))
 352     ;; Windows-31J is Windows Codepage 932.
 353     ,@(when (and (not (mm-coding-system-p 'windows-31j))
 354                  (mm-coding-system-p 'cp932))
 355         '((windows-31j . cp932)))
 356     ;; Charset name: GBK, Charset aliases: CP936, MS936, windows-936
 357     ;; http://www.iana.org/assignments/charset-reg/GBK
 358     ;; Emacs 22.1 has cp936, but not gbk, so we alias it:
 359     ,@(when (and (not (mm-coding-system-p 'gbk))
 360                  (mm-coding-system-p 'cp936))
 361         '((gbk . cp936)))
 362     ;; UTF8 is a bogus name for UTF-8
 363     ,@(when (and (not (mm-coding-system-p 'utf8))
 364                  (mm-coding-system-p 'utf-8))
 365         '((utf8 . utf-8)))
 366     ;; ISO8859-1 is a bogus name for ISO-8859-1
 367     ,@(when (and (not (mm-coding-system-p 'iso8859-1))
 368                  (mm-coding-system-p 'iso-8859-1))
 369         '((iso8859-1 . iso-8859-1)))
 370     ;; ISO_8859-1 is a bogus name for ISO-8859-1
 371     ,@(when (and (not (mm-coding-system-p 'iso_8859-1))
 372                  (mm-coding-system-p 'iso-8859-1))
 373         '((iso_8859-1 . iso-8859-1)))
 374     )
 375   "A mapping from unknown or invalid charset names to the real charset names.
 376
 377 See `mm-codepage-iso-8859-list' and `mm-codepage-ibm-list'.")
 378
 379 (defcustom mm-codepage-iso-8859-list
 380   (list 1250 ;; Windows-1250 is a variant of Latin-2 heavily used by Microsoft
 381         ;; Outlook users in Czech republic.  Use this to allow reading of
 382         ;; their e-mails.
 383         '(1252 . 1) ;; Windows-1252 is a superset of iso-8859-1 (West
 384                     ;; Europe).  See also `gnus-article-dumbquotes-map'.
 385         '(1254 . 9) ;; Windows-1254 is a superset of iso-8859-9 (Turkish).
 386         '(1255 . 8));; Windows-1255 is a superset of iso-8859-8 (Hebrew).
 387   "A list of Windows codepage numbers and iso-8859 charset numbers.
 388
 389 If an element is a number corresponding to a supported windows
 390 codepage, appropriate entries to `mm-charset-synonym-alist' are
 391 added by `mm-setup-codepage-iso-8859'.  An element may also be a
 392 cons cell where the car is a codepage number and the cdr is the
 393 corresponding number of an iso-8859 charset."
 394   :type '(list (set :inline t
 395                     (const 1250 :tag "Central and East European")
 396                     (const (1252 . 1) :tag "West European")
 397                     (const (1254 . 9) :tag "Turkish")
 398                     (const (1255 . 8) :tag "Hebrew"))
 399                (repeat :inline t
 400                        :tag "Other options"
 401                        (choice
 402                         (integer :tag "Windows codepage number")
 403                         (cons (integer :tag "Windows codepage number")
 404                               (integer :tag "iso-8859 charset  number")))))
 405   :version "22.1" ;; Gnus 5.10.9
 406   :group 'mime)
 407
 408 (defcustom mm-codepage-ibm-list
 409   (list 437 ;; (US etc.)
 410         860 ;; (Portugal)
 411         861 ;; (Iceland)
 412         862 ;; (Israel)
 413         863 ;; (Canadian French)
 414         865 ;; (Nordic)
 415         852 ;;
 416         850 ;; (Latin 1)
 417         855 ;; (Cyrillic)
 418         866 ;; (Cyrillic - Russian)
 419         857 ;; (Turkish)
 420         864 ;; (Arabic)
 421         869 ;; (Greek)
 422         874);; (Thai)
 423   ;; In Emacs 23 (unicode), cp... and ibm... are aliases.
 424   ;; Cf. http://thread.gmane.org/v9lkng5nwy.fsf@marauder.physik.uni-ulm.de
 425   "List of IBM codepage numbers.
 426
 427 The codepage mappings slighly differ between IBM and other vendors.
 428 See \"ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/IBM/README.TXT\".
 429
 430 If an element is a number corresponding to a supported windows
 431 codepage, appropriate entries to `mm-charset-synonym-alist' are
 432 added by `mm-setup-codepage-ibm'."
 433   :type '(list (set :inline t
 434                     (const 437 :tag "US etc.")
 435                     (const 860 :tag "Portugal")
 436                     (const 861 :tag "Iceland")
 437                     (const 862 :tag "Israel")
 438                     (const 863 :tag "Canadian French")
 439                     (const 865 :tag "Nordic")
 440                     (const 852)
 441                     (const 850 :tag "Latin 1")
 442                     (const 855 :tag "Cyrillic")
 443                     (const 866 :tag "Cyrillic - Russian")
 444                     (const 857 :tag "Turkish")
 445                     (const 864 :tag "Arabic")
 446                     (const 869 :tag "Greek")
 447                     (const 874 :tag "Thai"))
 448                (repeat :inline t
 449                        :tag "Other options"
 450                        (integer :tag "Codepage number")))
 451   :version "22.1" ;; Gnus 5.10.9
 452   :group 'mime)
 453
 454 (defun mm-setup-codepage-iso-8859 (&optional list)
 455   "Add appropriate entries to `mm-charset-synonym-alist'.
 456 Unless LIST is given, `mm-codepage-iso-8859-list' is used."
 457   (unless list
 458     (setq list mm-codepage-iso-8859-list))
 459   (dolist (i list)
 460     (let (cp windows iso)
 461       (if (consp i)
 462           (setq cp (intern (format "cp%d" (car i)))
 463                 windows (intern (format "windows-%d" (car i)))
 464                 iso (intern (format "iso-8859-%d" (cdr i))))
 465         (setq cp (intern (format "cp%d" i))
 466               windows (intern (format "windows-%d" i))))
 467       (unless (mm-coding-system-p windows)
 468         (if (mm-coding-system-p cp)
 469             (add-to-list 'mm-charset-synonym-alist (cons windows cp))
 470           (add-to-list 'mm-charset-synonym-alist (cons windows iso)))))))
 471
 472 (defun mm-setup-codepage-ibm (&optional list)
 473   "Add appropriate entries to `mm-charset-synonym-alist'.
 474 Unless LIST is given, `mm-codepage-ibm-list' is used."
 475   (unless list
 476     (setq list mm-codepage-ibm-list))
 477   (dolist (number list)
 478     (let ((ibm (intern (format "ibm%d" number)))
 479           (cp  (intern (format "cp%d" number))))
 480       (when (and (not (mm-coding-system-p ibm))
 481                  (mm-coding-system-p cp))
 482         (add-to-list 'mm-charset-synonym-alist (cons ibm cp))))))
 483
 484 ;; Initialize:
 485 (mm-setup-codepage-iso-8859)
 486 (mm-setup-codepage-ibm)
 487
 488 ;; Note: this has to be defined before `mm-charset-to-coding-system'.
 489 (defcustom mm-charset-eval-alist
 490   (if (featurep 'xemacs)
 491       nil ;; I don't know what would be useful for XEmacs.
 492     '(;; Emacs 22 provides autoloads for 1250-1258
 493       ;; (i.e. `mm-codepage-setup' does nothing).
 494       (windows-1250 . (mm-codepage-setup 1250 t))
 495       (windows-1251 . (mm-codepage-setup 1251 t))
 496       (windows-1253 . (mm-codepage-setup 1253 t))
 497       (windows-1257 . (mm-codepage-setup 1257 t))))
 498   "An alist of (CHARSET . FORM) pairs.
 499 If an article is encoded in an unknown CHARSET, FORM is
 500 evaluated.  This allows to load additional libraries providing
 501 charsets on demand.  If supported by your Emacs version, you
 502 could use `autoload-coding-system' here."
 503   :version "22.1" ;; Gnus 5.10.9
 504   :type '(list (set :inline t
 505                     (const (windows-1250 . (mm-codepage-setup 1250 t)))
 506                     (const (windows-1251 . (mm-codepage-setup 1251 t)))
 507                     (const (windows-1253 . (mm-codepage-setup 1253 t)))
 508                     (const (windows-1257 . (mm-codepage-setup 1257 t)))
 509                     (const (cp850 . (mm-codepage-setup 850 nil))))
 510                (repeat :inline t
 511                        :tag "Other options"
 512                        (cons (symbol :tag "charset")
 513                              (symbol :tag "form"))))
 514   :group 'mime)
 515 (put 'mm-charset-eval-alist 'risky-local-variable t)
 516
 517 (defvar mm-charset-override-alist)
 518
 519 ;; Note: this function has to be defined before `mm-charset-override-alist'
 520 ;; since it will use this function in order to determine its default value
 521 ;; when loading mm-util.elc.
 522 (defun mm-charset-to-coding-system (charset &optional lbt
 523                                             allow-override silent)
 524   "Return coding-system corresponding to CHARSET.
 525 CHARSET is a symbol naming a MIME charset.
 526 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
 527 used as the line break code type of the coding system.
 528
 529 If ALLOW-OVERRIDE is given, use `mm-charset-override-alist' to
 530 map undesired charset names to their replacement.  This should
 531 only be used for decoding, not for encoding.
 532
 533 A non-nil value of SILENT means don't issue a warning even if CHARSET
 534 is not available."
 535   ;; OVERRIDE is used (only) in `mm-decode-body' and `mm-decode-string'.
 536   (when (stringp charset)
 537     (setq charset (intern (downcase charset))))
 538   (when lbt
 539     (setq charset (intern (format "%s-%s" charset lbt))))
 540   (cond
 541    ((null charset)
 542     charset)
 543    ;; Running in a non-MULE environment.
 544    ((or (null (mm-get-coding-system-list))
 545         (not (fboundp 'coding-system-get)))
 546     charset)
 547    ;; Check override list quite early.  Should only used for decoding, not for
 548    ;; encoding!
 549    ((and allow-override
 550          (let ((cs (cdr (assq charset mm-charset-override-alist))))
 551            (and cs (mm-coding-system-p cs) cs))))
 552    ;; ascii
 553    ((eq charset 'us-ascii)
 554     'ascii)
 555    ;; Check to see whether we can handle this charset.  (This depends
 556    ;; on there being some coding system matching each `mime-charset'
 557    ;; property defined, as there should be.)
 558    ((and (mm-coding-system-p charset)
 559 ;;; Doing this would potentially weed out incorrect charsets.
 560 ;;;      charset
 561 ;;;      (eq charset (coding-system-get charset 'mime-charset))
 562          )
 563     charset)
 564    ;; Use coding system Emacs knows.
 565    ((and (fboundp 'coding-system-from-name)
 566          (coding-system-from-name charset)))
 567    ;; Eval expressions from `mm-charset-eval-alist'
 568    ((let* ((el (assq charset mm-charset-eval-alist))
 569            (cs (car el))
 570            (form (cdr el)))
 571       (and cs
 572            form
 573            (prog2
 574                ;; Avoid errors...
 575                (condition-case nil (eval form) (error nil))
 576                ;; (message "Failed to eval `%s'" form))
 577                (mm-coding-system-p cs)
 578              (message "Added charset `%s' via `mm-charset-eval-alist'" cs))
 579            cs)))
 580    ;; Translate invalid charsets.
 581    ((let ((cs (cdr (assq charset mm-charset-synonym-alist))))
 582       (and cs
 583            (mm-coding-system-p cs)
 584            ;; (message
 585            ;;  "Using synonym `%s' from `mm-charset-synonym-alist' for `%s'"
 586            ;;  cs charset)
 587            cs)))
 588    ;; Last resort: search the coding system list for entries which
 589    ;; have the right mime-charset in case the canonical name isn't
 590    ;; defined (though it should be).
 591    ((let (cs)
 592       ;; mm-get-coding-system-list returns a list of cs without lbt.
 593       ;; Do we need -lbt?
 594       (dolist (c (mm-get-coding-system-list))
 595         (if (and (null cs)
 596                  (eq charset (or (coding-system-get c :mime-charset)
 597                                  (coding-system-get c 'mime-charset))))
 598             (setq cs c)))
 599       (unless (or silent cs)
 600         ;; Warn the user about unknown charset:
 601         (if (fboundp 'gnus-message)
 602             (gnus-message 7 "Unknown charset: %s" charset)
 603           (message "Unknown charset: %s" charset)))
 604       cs))))
 605
 606 ;; Note: `mm-charset-to-coding-system' has to be defined before this.
 607 (defcustom mm-charset-override-alist
 608   ;; Note: pairs that cannot be used in the Emacs version currently running
 609   ;; will be removed.
 610   '((gb2312 . gbk)
 611     (iso-8859-1 . windows-1252)
 612     (iso-8859-8 . windows-1255)
 613     (iso-8859-9 . windows-1254))
 614   "A mapping from undesired charset names to their replacement.
 615
 616 You may add pairs like (iso-8859-1 . windows-1252) here,
 617 i.e. treat iso-8859-1 as windows-1252.  windows-1252 is a
 618 superset of iso-8859-1."
 619   :type
 620   '(list
 621     :convert-widget
 622     (lambda (widget)
 623       (let ((defaults
 624               (delq nil
 625                     (mapcar (lambda (pair)
 626                               (if (mm-charset-to-coding-system (cdr pair)
 627                                                                nil nil t)
 628                                   pair))
 629                             '((gb2312 . gbk)
 630                               (iso-8859-1 . windows-1252)
 631                               (iso-8859-8 . windows-1255)
 632                               (iso-8859-9 . windows-1254)
 633                               (undecided  . windows-1252)))))
 634             (val (copy-sequence (default-value 'mm-charset-override-alist)))
 635             pair rest)
 636         (while val
 637           (push (if (and (prog1
 638                              (setq pair (assq (caar val) defaults))
 639                            (setq defaults (delq pair defaults)))
 640                          (equal (car val) pair))
 641                     `(const ,pair)
 642                   `(cons :format "%v"
 643                          (const :format "(%v" ,(caar val))
 644                          (symbol :size 3 :format " . %v)\n" ,(cdar val))))
 645                 rest)
 646           (setq val (cdr val)))
 647         (while defaults
 648           (push `(const ,(pop defaults)) rest))
 649         (widget-convert
 650          'list
 651          `(set :inline t :format "%v" ,@(nreverse rest))
 652          `(repeat :inline t :tag "Other options"
 653                   (cons :format "%v"
 654                         (symbol :size 3 :format "(%v")
 655                         (symbol :size 3 :format " . %v)\n")))))))
 656   ;; Remove pairs that cannot be used in the Emacs version currently
 657   ;; running.  Note that this section will be evaluated when loading
 658   ;; mm-util.elc.
 659   :set (lambda (symbol value)
 660          (custom-set-default
 661           symbol (delq nil
 662                        (mapcar (lambda (pair)
 663                                  (if (mm-charset-to-coding-system (cdr pair)
 664                                                                   nil nil t)
 665                                      pair))
 666                                value))))
 667   :version "22.1" ;; Gnus 5.10.9
 668   :group 'mime)
 669
 670 (defvar mm-binary-coding-system
 671   (cond
 672    ((mm-coding-system-p 'binary) 'binary)
 673    ((mm-coding-system-p 'no-conversion) 'no-conversion)
 674    (t nil))
 675   "100% binary coding system.")
 676
 677 (defvar mm-text-coding-system
 678   (or (if (memq system-type '(windows-nt ms-dos))
 679           (and (mm-coding-system-p 'raw-text-dos) 'raw-text-dos)
 680         (and (mm-coding-system-p 'raw-text) 'raw-text))
 681       mm-binary-coding-system)
 682   "Text-safe coding system (For removing ^M).")
 683
 684 (defvar mm-text-coding-system-for-write nil
 685   "Text coding system for write.")
 686
 687 (defvar mm-auto-save-coding-system
 688   (cond
 689    ((mm-coding-system-p 'utf-8-emacs)   ; Mule 7
 690     (if (memq system-type '(windows-nt ms-dos))
 691         (if (mm-coding-system-p 'utf-8-emacs-dos)
 692             'utf-8-emacs-dos mm-binary-coding-system)
 693       'utf-8-emacs))
 694    ((mm-coding-system-p 'emacs-mule)
 695     (if (memq system-type '(windows-nt ms-dos))
 696         (if (mm-coding-system-p 'emacs-mule-dos)
 697             'emacs-mule-dos mm-binary-coding-system)
 698       'emacs-mule))
 699    ((mm-coding-system-p 'escape-quoted) 'escape-quoted)
 700    (t mm-binary-coding-system))
 701   "Coding system of auto save file.")
 702
 703 (defvar mm-universal-coding-system mm-auto-save-coding-system
 704   "The universal coding system.")
 705
 706 ;; Fixme: some of the cars here aren't valid MIME charsets.  That
 707 ;; should only matter with XEmacs, though.
 708 (defvar mm-mime-mule-charset-alist
 709   `((us-ascii ascii)
 710     (iso-8859-1 latin-iso8859-1)
 711     (iso-8859-2 latin-iso8859-2)
 712     (iso-8859-3 latin-iso8859-3)
 713     (iso-8859-4 latin-iso8859-4)
 714     (iso-8859-5 cyrillic-iso8859-5)
 715     ;; Non-mule (X)Emacs uses the last mule-charset for 8bit characters.
 716     ;; The fake mule-charset, gnus-koi8-r, tells Gnus that the default
 717     ;; charset is koi8-r, not iso-8859-5.
 718     (koi8-r cyrillic-iso8859-5 gnus-koi8-r)
 719     (iso-8859-6 arabic-iso8859-6)
 720     (iso-8859-7 greek-iso8859-7)
 721     (iso-8859-8 hebrew-iso8859-8)
 722     (iso-8859-9 latin-iso8859-9)
 723     (iso-8859-14 latin-iso8859-14)
 724     (iso-8859-15 latin-iso8859-15)
 725     (viscii vietnamese-viscii-lower)
 726     (iso-2022-jp latin-jisx0201 japanese-jisx0208 japanese-jisx0208-1978)
 727     (euc-kr korean-ksc5601)
 728     (gb2312 chinese-gb2312)
 729     (gbk chinese-gbk)
 730     (gb18030 gb18030-2-byte
 731              gb18030-4-byte-bmp gb18030-4-byte-smp
 732              gb18030-4-byte-ext-1 gb18030-4-byte-ext-2)
 733     (big5 chinese-big5-1 chinese-big5-2)
 734     (tibetan tibetan)
 735     (thai-tis620 thai-tis620)
 736     (windows-1251 cyrillic-iso8859-5)
 737     (iso-2022-7bit ethiopic arabic-1-column arabic-2-column)
 738     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
 739                    latin-jisx0201 japanese-jisx0208-1978
 740                    chinese-gb2312 japanese-jisx0208
 741                    korean-ksc5601 japanese-jisx0212)
 742     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
 743                     latin-jisx0201 japanese-jisx0208-1978
 744                     chinese-gb2312 japanese-jisx0208
 745                     korean-ksc5601 japanese-jisx0212
 746                     chinese-cns11643-1 chinese-cns11643-2)
 747     (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
 748                     cyrillic-iso8859-5 greek-iso8859-7
 749                     latin-jisx0201 japanese-jisx0208-1978
 750                     chinese-gb2312 japanese-jisx0208
 751                     korean-ksc5601 japanese-jisx0212
 752                     chinese-cns11643-1 chinese-cns11643-2
 753                     chinese-cns11643-3 chinese-cns11643-4
 754                     chinese-cns11643-5 chinese-cns11643-6
 755                     chinese-cns11643-7)
 756     (iso-2022-jp-3 latin-jisx0201 japanese-jisx0208-1978 japanese-jisx0208
 757                    japanese-jisx0213-1 japanese-jisx0213-2)
 758     (shift_jis latin-jisx0201 katakana-jisx0201 japanese-jisx0208)
 759     ,(cond ((fboundp 'unicode-precedence-list)
 760             (cons 'utf-8 (delq 'ascii (mapcar 'charset-name
 761                                               (unicode-precedence-list)))))
 762            ((or (not (fboundp 'charsetp)) ;; non-Mule case
 763                 (charsetp 'unicode-a)
 764                 (not (mm-coding-system-p 'mule-utf-8)))
 765             '(utf-8 unicode-a unicode-b unicode-c unicode-d unicode-e))
 766            (t ;; If we have utf-8 we're in Mule 5+.
 767             (append '(utf-8)
 768                     (delete 'ascii
 769                             (coding-system-get 'mule-utf-8 'safe-charsets))))))
 770   "Alist of MIME-charset/MULE-charsets.")
 771
 772 (defun mm-enrich-utf-8-by-mule-ucs ()
 773   "Make the `utf-8' MIME charset usable by the Mule-UCS package.
 774 This function will run when the `un-define' module is loaded under
 775 XEmacs, and fill the `utf-8' entry in `mm-mime-mule-charset-alist'
 776 with Mule charsets.  It is completely useless for Emacs."
 777   (when (boundp 'unicode-basic-translation-charset-order-list)
 778     (condition-case nil
 779         (let ((val (delq
 780                     'ascii
 781                     (copy-sequence
 782                      (symbol-value
 783                       'unicode-basic-translation-charset-order-list))))
 784               (elem (assq 'utf-8 mm-mime-mule-charset-alist)))
 785           (if elem
 786               (setcdr elem val)
 787             (setq mm-mime-mule-charset-alist
 788                   (nconc mm-mime-mule-charset-alist
 789                          (list (cons 'utf-8 val))))))
 790       (error))))
 791
 792 ;; Correct by construction, but should be unnecessary for Emacs:
 793 (if (featurep 'xemacs)
 794     (eval-after-load "un-define" '(mm-enrich-utf-8-by-mule-ucs))
 795   (when (and (fboundp 'coding-system-list)
 796              (fboundp 'sort-coding-systems))
 797     (let ((css (sort-coding-systems (coding-system-list 'base-only)))
 798           cs mime mule alist)
 799       (while css
 800         (setq cs (pop css)
 801               mime (or (coding-system-get cs :mime-charset); Emacs 23 (unicode)
 802                        (coding-system-get cs 'mime-charset)))
 803         (when (and mime
 804                    (not (eq t (setq mule
 805                                     (coding-system-get cs 'safe-charsets))))
 806                    (not (assq mime alist)))
 807           (push (cons mime (delq 'ascii mule)) alist)))
 808       (setq mm-mime-mule-charset-alist (nreverse alist)))))
 809
 810 (defvar mm-hack-charsets '(iso-8859-15 iso-2022-jp-2)
 811   "A list of special charsets.
 812 Valid elements include:
 813 `iso-8859-15'    convert ISO-8859-1, -9 to ISO-8859-15 if ISO-8859-15 exists.
 814 `iso-2022-jp-2'  convert ISO-2022-jp to ISO-2022-jp-2 if ISO-2022-jp-2 exists."
 815 )
 816
 817 (defvar mm-iso-8859-15-compatible
 818   '((iso-8859-1 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE")
 819     (iso-8859-9 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE\xD0\xDD\xDE\xF0\xFD\xFE"))
 820   "ISO-8859-15 exchangeable coding systems and inconvertible characters.")
 821
 822 (defvar mm-iso-8859-x-to-15-table
 823   (and (fboundp 'coding-system-p)
 824        (mm-coding-system-p 'iso-8859-15)
 825        (mapcar
 826         (lambda (cs)
 827           (if (mm-coding-system-p (car cs))
 828               (let ((c (string-to-char
 829                         (decode-coding-string "\341" (car cs)))))
 830                 (cons (char-charset c)
 831                       (cons
 832                        (- (string-to-char
 833                            (decode-coding-string "\341" 'iso-8859-15)) c)
 834                        (string-to-list (decode-coding-string (car (cdr cs))
 835                                                              (car cs))))))
 836             '(gnus-charset 0)))
 837         mm-iso-8859-15-compatible))
 838   "A table of the difference character between ISO-8859-X and ISO-8859-15.")
 839
 840 (defcustom mm-coding-system-priorities
 841   (let ((lang (if (boundp 'current-language-environment)
 842                   (symbol-value 'current-language-environment))))
 843     (cond (;; XEmacs without Mule but with `file-coding'.
 844            (not lang) nil)
 845           ;; In XEmacs 21.5 it may be the one like "Japanese (UTF-8)".
 846           ((string-match "\\`Japanese" lang)
 847            ;; Japanese users prefer iso-2022-jp to euc-japan or
 848            ;; shift_jis, however iso-8859-1 should be used when
 849            ;; there are only ASCII text and Latin-1 characters.
 850            '(iso-8859-1 iso-2022-jp iso-2022-jp-2 shift_jis utf-8))))
 851   "Preferred coding systems for encoding outgoing messages.
 852
 853 More than one suitable coding system may be found for some text.
 854 By default, the coding system with the highest priority is used
 855 to encode outgoing messages (see `sort-coding-systems').  If this
 856 variable is set, it overrides the default priority."
 857   :version "21.2"
 858   :type '(repeat (symbol :tag "Coding system"))
 859   :group 'mime)
 860
 861 ;; ??
 862 (defvar mm-use-find-coding-systems-region
 863   (fboundp 'find-coding-systems-region)
 864   "Use `find-coding-systems-region' to find proper coding systems.
 865
 866 Setting it to nil is useful on Emacsen supporting Unicode if sending
 867 mail with multiple parts is preferred to sending a Unicode one.")
 868
 869 ;;; Internal variables:
 870
 871 ;;; Functions:
 872
 873 (defun mm-mule-charset-to-mime-charset (charset)
 874   "Return the MIME charset corresponding to the given Mule CHARSET."
 875   (if (and (fboundp 'find-coding-systems-for-charsets)
 876            (fboundp 'sort-coding-systems))
 877       (let ((css (sort (sort-coding-systems
 878                         (find-coding-systems-for-charsets (list charset)))
 879                        'mm-sort-coding-systems-predicate))
 880             cs mime)
 881         (while (and (not mime)
 882                     css)
 883           (when (setq cs (pop css))
 884             (setq mime (or (coding-system-get cs :mime-charset)
 885                            (coding-system-get cs 'mime-charset)))))
 886         mime)
 887     (let ((alist (mapcar (lambda (cs)
 888                            (assq cs mm-mime-mule-charset-alist))
 889                          (sort (mapcar 'car mm-mime-mule-charset-alist)
 890                                'mm-sort-coding-systems-predicate)))
 891           out)
 892       (while alist
 893         (when (memq charset (cdar alist))
 894           (setq out (caar alist)
 895                 alist nil))
 896         (pop alist))
 897       out)))
 898
 899 (eval-and-compile
 900   (if (featurep 'xemacs)
 901       (defalias 'mm-enable-multibyte 'ignore)
 902     (defun mm-enable-multibyte ()
 903       "Set the multibyte flag of the current buffer.
 904 Only do this if the default value of `enable-multibyte-characters' is
 905 non-nil.  This is a no-op in XEmacs."
 906       (set-buffer-multibyte 'to)))
 907
 908   (if (featurep 'xemacs)
 909       (defalias 'mm-disable-multibyte 'ignore)
 910     (defun mm-disable-multibyte ()
 911       "Unset the multibyte flag of in the current buffer.
 912 This is a no-op in XEmacs."
 913       (set-buffer-multibyte nil))))
 914
 915 (defun mm-preferred-coding-system (charset)
 916   ;; A typo in some Emacs versions.
 917   (or (get-charset-property charset 'preferred-coding-system)
 918       (get-charset-property charset 'prefered-coding-system)))
 919
 920 ;; Mule charsets shouldn't be used.
 921 (defsubst mm-guess-charset ()
 922   "Guess Mule charset from the language environment."
 923   (or
 924    mail-parse-mule-charset ;; cached mule-charset
 925    (progn
 926      (setq mail-parse-mule-charset
 927            (and (boundp 'current-language-environment)
 928                 (car (last
 929                       (assq 'charset
 930                             (assoc current-language-environment
 931                                    language-info-alist))))))
 932      (if (or (not mail-parse-mule-charset)
 933              (eq mail-parse-mule-charset 'ascii))
 934          (setq mail-parse-mule-charset
 935                (or (car (last (assq mail-parse-charset
 936                                     mm-mime-mule-charset-alist)))
 937                    ;; default
 938                    'latin-iso8859-1)))
 939      mail-parse-mule-charset)))
 940
 941 (defun mm-charset-after (&optional pos)
 942   "Return charset of a character in current buffer at position POS.
 943 If POS is nil, it defauls to the current point.
 944 If POS is out of range, the value is nil.
 945 If the charset is `composition', return the actual one."
 946   (let ((char (char-after pos)) charset)
 947     (if (< (mm-char-int char) 128)
 948         (setq charset 'ascii)
 949       ;; charset-after is fake in some Emacsen.
 950       (setq charset (and (fboundp 'char-charset) (char-charset char)))
 951       (if (eq charset 'composition)     ; Mule 4
 952           (let ((p (or pos (point))))
 953             (cadr (find-charset-region p (1+ p))))
 954         (if (and charset (not (memq charset '(ascii eight-bit-control
 955                                                     eight-bit-graphic))))
 956             charset
 957           (mm-guess-charset))))))
 958
 959 (defun mm-mime-charset (charset)
 960   "Return the MIME charset corresponding to the given Mule CHARSET."
 961   (if (eq charset 'unknown)
 962       (error "The message contains non-printable characters, please use attachment"))
 963   (if (and (fboundp 'coding-system-get) (fboundp 'get-charset-property))
 964       (or
 965        (and (mm-preferred-coding-system charset)
 966             (or (coding-system-get
 967                  (mm-preferred-coding-system charset) :mime-charset)
 968                 (coding-system-get
 969                  (mm-preferred-coding-system charset) 'mime-charset)))
 970        (and (eq charset 'ascii)
 971             'us-ascii)
 972        (mm-preferred-coding-system charset)
 973        (mm-mule-charset-to-mime-charset charset))
 974     ;; This is for XEmacs.
 975     (mm-mule-charset-to-mime-charset charset)))
 976
 977 (if (fboundp 'delete-dups)
 978     (defalias 'mm-delete-duplicates 'delete-dups)
 979   (defun mm-delete-duplicates (list)
 980     "Destructively remove `equal' duplicates from LIST.
 981 Store the result in LIST and return it.  LIST must be a proper list.
 982 Of several `equal' occurrences of an element in LIST, the first
 983 one is kept.
 984
 985 This is a compatibility function for Emacsen without `delete-dups'."
 986     ;; Code from `subr.el' in Emacs 22:
 987     (let ((tail list))
 988       (while tail
 989         (setcdr tail (delete (car tail) (cdr tail)))
 990         (setq tail (cdr tail))))
 991     list))
 992
 993 ;; Fixme:  This is used in places when it should be testing the
 994 ;; default multibyteness.  See mm-default-multibyte-p.
 995 (eval-and-compile
 996   (if (and (not (featurep 'xemacs))
 997            (boundp 'enable-multibyte-characters))
 998       (defun mm-multibyte-p ()
 999         "Non-nil if multibyte is enabled in the current buffer."
1000         enable-multibyte-characters)
1001     (defun mm-multibyte-p () (featurep 'mule))))
1002
1003 (defun mm-default-multibyte-p ()
1004   "Return non-nil if the session is multibyte.
1005 This affects whether coding conversion should be attempted generally."
1006   (if (featurep 'mule)
1007       (if (boundp 'enable-multibyte-characters)
1008           (default-value 'enable-multibyte-characters)
1009         t)))
1010
1011 (defun mm-iso-8859-x-to-15-region (&optional b e)
1012   (if (fboundp 'char-charset)
1013       (let (charset item c inconvertible)
1014         (save-restriction
1015           (if e (narrow-to-region b e))
1016           (goto-char (point-min))
1017           (skip-chars-forward "\0-\177")
1018           (while (not (eobp))
1019             (cond
1020              ((not (setq item (assq (char-charset (setq c (char-after)))
1021                                     mm-iso-8859-x-to-15-table)))
1022               (forward-char))
1023              ((memq c (cdr (cdr item)))
1024               (setq inconvertible t)
1025               (forward-char))
1026              (t
1027               (insert-before-markers (prog1 (+ c (car (cdr item)))
1028                                        (delete-char 1)))))
1029             (skip-chars-forward "\0-\177")))
1030         (not inconvertible))))
1031
1032 (defun mm-sort-coding-systems-predicate (a b)
1033   (let ((priorities
1034          (mapcar (lambda (cs)
1035                    ;; Note: invalid entries are dropped silently
1036                    (and (setq cs (mm-coding-system-p cs))
1037                         (coding-system-base cs)))
1038                  mm-coding-system-priorities)))
1039     (and (setq a (mm-coding-system-p a))
1040          (if (setq b (mm-coding-system-p b))
1041              (> (length (memq (coding-system-base a) priorities))
1042                 (length (memq (coding-system-base b) priorities)))
1043            t))))
1044
1045 (eval-when-compile
1046   (autoload 'latin-unity-massage-name "latin-unity")
1047   (autoload 'latin-unity-maybe-remap "latin-unity")
1048   (autoload 'latin-unity-representations-feasible-region "latin-unity")
1049   (autoload 'latin-unity-representations-present-region "latin-unity"))
1050
1051 (defvar latin-unity-coding-systems)
1052 (defvar latin-unity-ucs-list)
1053
1054 (defun mm-xemacs-find-mime-charset-1 (begin end)
1055   "Determine which MIME charset to use to send region as message.
1056 This uses the XEmacs-specific latin-unity package to better handle the
1057 case where identical characters from diverse ISO-8859-? character sets
1058 can be encoded using a single one of the corresponding coding systems.
1059
1060 It treats `mm-coding-system-priorities' as the list of preferred
1061 coding systems; a useful example setting for this list in Western
1062 Europe would be '(iso-8859-1 iso-8859-15 utf-8), which would default
1063 to the very standard Latin 1 coding system, and only move to coding
1064 systems that are less supported as is necessary to encode the
1065 characters that exist in the buffer.
1066
1067 Latin Unity doesn't know about those non-ASCII Roman characters that
1068 are available in various East Asian character sets.  As such, its
1069 behavior if you have a JIS 0212 LATIN SMALL LETTER A WITH ACUTE in a
1070 buffer and it can otherwise be encoded as Latin 1, won't be ideal.
1071 But this is very much a corner case, so don't worry about it."
1072   (let ((systems mm-coding-system-priorities) csets psets curset)
1073
1074     ;; Load the Latin Unity library, if available.
1075     (when (and (not (featurep 'latin-unity)) (locate-library "latin-unity"))
1076       (require 'latin-unity))
1077
1078     ;; Now, can we use it?
1079     (if (featurep 'latin-unity)
1080         (progn
1081           (setq csets (latin-unity-representations-feasible-region begin end)
1082                 psets (latin-unity-representations-present-region begin end))
1083
1084           (catch 'done
1085
1086             ;; Pass back the first coding system in the preferred list
1087             ;; that can encode the whole region.
1088             (dolist (curset systems)
1089               (setq curset (latin-unity-massage-name 'buffer-default curset))
1090
1091               ;; If the coding system is a universal coding system, then
1092               ;; it can certainly encode all the characters in the region.
1093               (if (memq curset latin-unity-ucs-list)
1094                   (throw 'done (list curset)))
1095
1096               ;; If a coding system isn't universal, and isn't in
1097               ;; the list that latin unity knows about, we can't
1098               ;; decide whether to use it here. Leave that until later
1099               ;; in `mm-find-mime-charset-region' function, whence we
1100               ;; have been called.
1101               (unless (memq curset latin-unity-coding-systems)
1102                 (throw 'done nil))
1103
1104               ;; Right, we know about this coding system, and it may
1105               ;; conceivably be able to encode all the characters in
1106               ;; the region.
1107               (if (latin-unity-maybe-remap begin end curset csets psets t)
1108                   (throw 'done (list curset))))
1109
1110             ;; Can't encode using anything from the
1111             ;; `mm-coding-system-priorities' list.
1112             ;; Leave `mm-find-mime-charset' to do most of the work.
1113             nil))
1114
1115       ;; Right, latin unity isn't available; let `mm-find-charset-region'
1116       ;; take its default action, which equally applies to GNU Emacs.
1117       nil)))
1118
1119 (defmacro mm-xemacs-find-mime-charset (begin end)
1120   (when (featurep 'xemacs)
1121     `(and (featurep 'mule) (mm-xemacs-find-mime-charset-1 ,begin ,end))))
1122
1123 (declare-function mm-delete-duplicates "mm-util" (list))
1124
1125 (defun mm-find-mime-charset-region (b e &optional hack-charsets)
1126   "Return the MIME charsets needed to encode the region between B and E.
1127 nil means ASCII, a single-element list represents an appropriate MIME
1128 charset, and a longer list means no appropriate charset."
1129   (let (charsets)
1130     ;; The return possibilities of this function are a mess...
1131     (or (and (mm-multibyte-p)
1132              mm-use-find-coding-systems-region
1133              ;; Find the mime-charset of the most preferred coding
1134              ;; system that has one.
1135              (let ((systems (find-coding-systems-region b e)))
1136                (when mm-coding-system-priorities
1137                  (setq systems
1138                        (sort systems 'mm-sort-coding-systems-predicate)))
1139                (setq systems (delq 'compound-text systems))
1140                (unless (equal systems '(undecided))
1141                  (while systems
1142                    (let* ((head (pop systems))
1143                           (cs (or (coding-system-get head :mime-charset)
1144                                   (coding-system-get head 'mime-charset))))
1145                      ;; The mime-charset (`x-ctext') of
1146                      ;; `compound-text' is not in the IANA list.  We
1147                      ;; shouldn't normally use anything here with a
1148                      ;; mime-charset having an `x-' prefix.
1149                      ;; Fixme:  Allow this to be overridden, since
1150                      ;; there is existing use of x-ctext.
1151                      ;; Also people apparently need the coding system
1152                      ;; `iso-2022-jp-3' (which Mule-UCS defines with
1153                      ;; mime-charset, though it's not valid).
1154                      (if (and cs
1155                               (not (string-match "^[Xx]-" (symbol-name cs)))
1156                               ;; UTF-16 of any variety is invalid for
1157                               ;; text parts and, unfortunately, has
1158                               ;; mime-charset defined both in Mule-UCS
1159                               ;; and versions of Emacs.  (The name
1160                               ;; might be `mule-utf-16...'  or
1161                               ;; `utf-16...'.)
1162                               (not (string-match "utf-16" (symbol-name cs))))
1163                          (setq systems nil
1164                                charsets (list cs))))))
1165                charsets))
1166         ;; If we're XEmacs, and some coding system is appropriate,
1167         ;; mm-xemacs-find-mime-charset will return an appropriate list.
1168         ;; Otherwise, we'll get nil, and the next setq will get invoked.
1169         (setq charsets (mm-xemacs-find-mime-charset b e))
1170
1171         ;; Fixme: won't work for unibyte Emacs 23:
1172
1173         ;; We're not multibyte, or a single coding system won't cover it.
1174         (setq charsets
1175               (mm-delete-duplicates
1176                (mapcar 'mm-mime-charset
1177                        (delq 'ascii
1178                              (mm-find-charset-region b e))))))
1179     (if (and (> (length charsets) 1)
1180              (memq 'iso-8859-15 charsets)
1181              (memq 'iso-8859-15 hack-charsets)
1182              (save-excursion (mm-iso-8859-x-to-15-region b e)))
1183         (dolist (x mm-iso-8859-15-compatible)
1184           (setq charsets (delq (car x) charsets))))
1185     (if (and (memq 'iso-2022-jp-2 charsets)
1186              (memq 'iso-2022-jp-2 hack-charsets))
1187         (setq charsets (delq 'iso-2022-jp charsets)))
1188     ;; Attempt to reduce the number of charsets if utf-8 is available.
1189     (if (and (featurep 'xemacs)
1190              (> (length charsets) 1)
1191              (mm-coding-system-p 'utf-8))
1192         (let ((mm-coding-system-priorities
1193                (cons 'utf-8 mm-coding-system-priorities)))
1194           (setq charsets
1195                 (mm-delete-duplicates
1196                  (mapcar 'mm-mime-charset
1197                          (delq 'ascii
1198                                (mm-find-charset-region b e)))))))
1199     charsets))
1200
1201 (defmacro mm-with-unibyte-buffer (&rest forms)
1202   "Create a temporary buffer, and evaluate FORMS there like `progn'.
1203 Use unibyte mode for this."
1204   `(with-temp-buffer
1205      (mm-disable-multibyte)
1206      ,@forms))
1207 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
1208 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
1209
1210 (defmacro mm-with-multibyte-buffer (&rest forms)
1211   "Create a temporary buffer, and evaluate FORMS there like `progn'.
1212 Use multibyte mode for this."
1213   `(with-temp-buffer
1214      (mm-enable-multibyte)
1215      ,@forms))
1216 (put 'mm-with-multibyte-buffer 'lisp-indent-function 0)
1217 (put 'mm-with-multibyte-buffer 'edebug-form-spec '(body))
1218
1219 (defmacro mm-with-unibyte-current-buffer (&rest forms)
1220   "Evaluate FORMS with current buffer temporarily made unibyte.
1221 Equivalent to `progn' in XEmacs.
1222
1223 Note: We recommend not using this macro any more; there should be
1224 better ways to do a similar thing.  The previous version of this macro
1225 bound the default value of `enable-multibyte-characters' to nil while
1226 evaluating FORMS but it is no longer done.  So, some programs assuming
1227 it if any may malfunction."
1228   (if (featurep 'xemacs)
1229       `(progn ,@forms)
1230     (let ((multibyte (make-symbol "multibyte")))
1231       `(let ((,multibyte enable-multibyte-characters))
1232          (when ,multibyte
1233            (set-buffer-multibyte nil))
1234          (prog1
1235              (progn ,@forms)
1236            (when ,multibyte
1237              (set-buffer-multibyte t)))))))
1238 (put 'mm-with-unibyte-current-buffer 'lisp-indent-function 0)
1239 (put 'mm-with-unibyte-current-buffer 'edebug-form-spec '(body))
1240
1241 (defun mm-find-charset-region (b e)
1242   "Return a list of Emacs charsets in the region B to E."
1243   (cond
1244    ((and (mm-multibyte-p)
1245          (fboundp 'find-charset-region))
1246     ;; Remove composition since the base charsets have been included.
1247     ;; Remove eight-bit-*, treat them as ascii.
1248     (let ((css (find-charset-region b e)))
1249       (dolist (cs
1250                '(composition eight-bit-control eight-bit-graphic control-1)
1251                css)
1252         (setq css (delq cs css)))))
1253    (t
1254     ;; We are in a unibyte buffer or XEmacs non-mule, so we futz around a bit.
1255     (save-excursion
1256       (save-restriction
1257         (narrow-to-region b e)
1258         (goto-char (point-min))
1259         (skip-chars-forward "\0-\177")
1260         (if (eobp)
1261             '(ascii)
1262           (let (charset)
1263             (setq charset
1264                   (and (boundp 'current-language-environment)
1265                        (car (last (assq 'charset
1266                                         (assoc current-language-environment
1267                                                language-info-alist))))))
1268             (if (eq charset 'ascii) (setq charset nil))
1269             (or charset
1270                 (setq charset
1271                       (car (last (assq mail-parse-charset
1272                                        mm-mime-mule-charset-alist)))))
1273             (list 'ascii (or charset 'latin-iso8859-1)))))))))
1274
1275 (defun mm-auto-mode-alist ()
1276   "Return an `auto-mode-alist' with only the .gz (etc) thingies."
1277   (let ((alist auto-mode-alist)
1278         out)
1279     (while alist
1280       (when (listp (cdar alist))
1281         (push (car alist) out))
1282       (pop alist))
1283     (nreverse out)))
1284
1285 (defvar mm-inhibit-file-name-handlers
1286   '(jka-compr-handler image-file-handler epa-file-handler)
1287   "A list of handlers doing (un)compression (etc) thingies.")
1288
1289 (defun mm-insert-file-contents (filename &optional visit beg end replace
1290                                          inhibit)
1291   "Like `insert-file-contents', but only reads in the file.
1292 A buffer may be modified in several ways after reading into the buffer due
1293 to advanced Emacs features, such as file-name-handlers, format decoding,
1294 `find-file-hooks', etc.
1295 If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'.
1296   This function ensures that none of these modifications will take place."
1297   (letf* ((format-alist nil)
1298           (auto-mode-alist (if inhibit nil (mm-auto-mode-alist)))
1299           ((default-value 'major-mode) 'fundamental-mode)
1300           (enable-local-variables nil)
1301           (after-insert-file-functions nil)
1302           (enable-local-eval nil)
1303           (inhibit-file-name-operation (if inhibit
1304                                            'insert-file-contents
1305                                          inhibit-file-name-operation))
1306           (inhibit-file-name-handlers
1307            (if inhibit
1308                (append mm-inhibit-file-name-handlers
1309                        inhibit-file-name-handlers)
1310              inhibit-file-name-handlers))
1311           (ffh (if (boundp 'find-file-hook)
1312                    'find-file-hook
1313                  'find-file-hooks))
1314           (val (symbol-value ffh)))
1315     (set ffh nil)
1316     (unwind-protect
1317         (insert-file-contents filename visit beg end replace)
1318       (set ffh val))))
1319
1320 (defun mm-append-to-file (start end filename &optional codesys inhibit)
1321   "Append the contents of the region to the end of file FILENAME.
1322 When called from a function, expects three arguments,
1323 START, END and FILENAME.  START and END are buffer positions
1324 saying what text to write.
1325 Optional fourth argument specifies the coding system to use when
1326 encoding the file.
1327 If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'."
1328   (let ((coding-system-for-write
1329          (or codesys mm-text-coding-system-for-write
1330              mm-text-coding-system))
1331         (inhibit-file-name-operation (if inhibit
1332                                          'append-to-file
1333                                        inhibit-file-name-operation))
1334         (inhibit-file-name-handlers
1335          (if inhibit
1336              (append mm-inhibit-file-name-handlers
1337                      inhibit-file-name-handlers)
1338            inhibit-file-name-handlers)))
1339     (write-region start end filename t 'no-message)
1340     (message "Appended to %s" filename)))
1341
1342 (defun mm-write-region (start end filename &optional append visit lockname
1343                               coding-system inhibit)
1344
1345   "Like `write-region'.
1346 If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'."
1347   (let ((coding-system-for-write
1348          (or coding-system mm-text-coding-system-for-write
1349              mm-text-coding-system))
1350         (inhibit-file-name-operation (if inhibit
1351                                          'write-region
1352                                        inhibit-file-name-operation))
1353         (inhibit-file-name-handlers
1354          (if inhibit
1355              (append mm-inhibit-file-name-handlers
1356                      inhibit-file-name-handlers)
1357            inhibit-file-name-handlers)))
1358     (write-region start end filename append visit lockname)))
1359
1360 (autoload 'gmm-write-region "gmm-utils")
1361
1362 ;; It is not a MIME function, but some MIME functions use it.
1363 (if (and (fboundp 'make-temp-file)
1364          (ignore-errors
1365            (let ((def (symbol-function 'make-temp-file)))
1366              (and (byte-code-function-p def)
1367                   (setq def (if (fboundp 'compiled-function-arglist)
1368                                 ;; XEmacs
1369                                 (eval (list 'compiled-function-arglist def))
1370                               (aref def 0)))
1371                   (>= (length def) 4)
1372                   (eq (nth 3 def) 'suffix)))))
1373     (defalias 'mm-make-temp-file 'make-temp-file)
1374   ;; Stolen (and modified for XEmacs) from Emacs 22.
1375   (defun mm-make-temp-file (prefix &optional dir-flag suffix)
1376     "Create a temporary file.
1377 The returned file name (created by appending some random characters at the end
1378 of PREFIX, and expanding against `temporary-file-directory' if necessary),
1379 is guaranteed to point to a newly created empty file.
1380 You can then use `write-region' to write new data into the file.
1381
1382 If DIR-FLAG is non-nil, create a new empty directory instead of a file.
1383
1384 If SUFFIX is non-nil, add that at the end of the file name."
1385     (let ((umask (default-file-modes))
1386           file)
1387       (unwind-protect
1388           (progn
1389             ;; Create temp files with strict access rights.  It's easy to
1390             ;; loosen them later, whereas it's impossible to close the
1391             ;; time-window of loose permissions otherwise.
1392             (set-default-file-modes 448)
1393             (while (condition-case err
1394                        (progn
1395                          (setq file
1396                                (make-temp-name
1397                                 (expand-file-name
1398                                  prefix
1399                                  (if (fboundp 'temp-directory)
1400                                      ;; XEmacs
1401                                      (temp-directory)
1402                                    temporary-file-directory))))
1403                          (if suffix
1404                              (setq file (concat file suffix)))
1405                          (if dir-flag
1406                              (make-directory file)
1407                            ;; NOTE: This is unsafe if Emacs 20
1408                            ;; users and XEmacs users don't use
1409                            ;; a secure temp directory.
1410                            (gmm-write-region "" nil file nil 'silent
1411                                              nil 'excl))
1412                          nil)
1413                      (file-already-exists t)
1414                      ;; The XEmacs version of `make-directory' issues
1415                      ;; `file-error'.
1416                      (file-error (or (and (featurep 'xemacs)
1417                                           (file-exists-p file))
1418                                      (signal (car err) (cdr err)))))
1419               ;; the file was somehow created by someone else between
1420               ;; `make-temp-name' and `write-region', let's try again.
1421               nil)
1422             file)
1423         ;; Reset the umask.
1424         (set-default-file-modes umask)))))
1425
1426 (defvar mm-image-load-path-cache nil)
1427
1428 (defun mm-image-load-path (&optional package)
1429   (if (and mm-image-load-path-cache
1430            (equal load-path (car mm-image-load-path-cache)))
1431       (cdr mm-image-load-path-cache)
1432     (let (dir result)
1433       (dolist (path load-path)
1434         (when (and path
1435                    (file-directory-p
1436                     (setq dir (concat (file-name-directory
1437                                        (directory-file-name path))
1438                                       "etc/images/" (or package "gnus/")))))
1439           (push dir result)))
1440       (setq result (nreverse result)
1441             mm-image-load-path-cache (cons load-path result))
1442       result)))
1443
1444 ;; Fixme: This doesn't look useful where it's used.
1445 (if (fboundp 'detect-coding-region)
1446     (defun mm-detect-coding-region (start end)
1447       "Like `detect-coding-region' except returning the best one."
1448       (let ((coding-systems
1449              (detect-coding-region start end)))
1450         (or (car-safe coding-systems)
1451             coding-systems)))
1452   (defun mm-detect-coding-region (start end)
1453     (let ((point (point)))
1454       (goto-char start)
1455       (skip-chars-forward "\0-\177" end)
1456       (prog1
1457           (if (eq (point) end) 'ascii (mm-guess-charset))
1458         (goto-char point)))))
1459
1460 (declare-function mm-detect-coding-region "mm-util" (start end))
1461
1462 (if (fboundp 'coding-system-get)
1463     (defun mm-detect-mime-charset-region (start end)
1464       "Detect MIME charset of the text in the region between START and END."
1465       (let ((cs (mm-detect-coding-region start end)))
1466         (or (coding-system-get cs :mime-charset)
1467             (coding-system-get cs 'mime-charset))))
1468   (defun mm-detect-mime-charset-region (start end)
1469     "Detect MIME charset of the text in the region between START and END."
1470     (let ((cs (mm-detect-coding-region start end)))
1471       cs)))
1472
1473 (eval-when-compile
1474   (unless (fboundp 'coding-system-to-mime-charset)
1475     (defalias 'coding-system-to-mime-charset 'ignore)))
1476
1477 (defun mm-coding-system-to-mime-charset (coding-system)
1478   "Return the MIME charset corresponding to CODING-SYSTEM.
1479 To make this function work with XEmacs, the APEL package is required."
1480   (when coding-system
1481     (or (and (fboundp 'coding-system-get)
1482              (or (coding-system-get coding-system :mime-charset)
1483                  (coding-system-get coding-system 'mime-charset)))
1484         (and (featurep 'xemacs)
1485              (or (and (fboundp 'coding-system-to-mime-charset)
1486                       (not (eq (symbol-function 'coding-system-to-mime-charset)
1487                                'ignore)))
1488                  (and (condition-case nil
1489                           (require 'mcharset)
1490                         (error nil))
1491                       (fboundp 'coding-system-to-mime-charset)))
1492              (coding-system-to-mime-charset coding-system)))))
1493
1494 (eval-when-compile
1495   (require 'jka-compr))
1496
1497 (defun mm-decompress-buffer (filename &optional inplace force)
1498   "Decompress buffer's contents, depending on jka-compr.
1499 Only when FORCE is t or `auto-compression-mode' is enabled and FILENAME
1500 agrees with `jka-compr-compression-info-list', decompression is done.
1501 Signal an error if FORCE is neither nil nor t and compressed data are
1502 not decompressed because `auto-compression-mode' is disabled.
1503 If INPLACE is nil, return decompressed data or nil without modifying
1504 the buffer.  Otherwise, replace the buffer's contents with the
1505 decompressed data.  The buffer's multibyteness must be turned off."
1506   (when (and filename
1507              (if force
1508                  (prog1 t (require 'jka-compr))
1509                (and (fboundp 'jka-compr-installed-p)
1510                     (jka-compr-installed-p))))
1511     (let ((info (jka-compr-get-compression-info filename)))
1512       (when info
1513         (unless (or (memq force (list nil t))
1514                     (jka-compr-installed-p))
1515           (error ""))
1516         (let ((prog (jka-compr-info-uncompress-program info))
1517               (args (jka-compr-info-uncompress-args info))
1518               (msg (format "%s %s..."
1519                            (jka-compr-info-uncompress-message info)
1520                            filename))
1521               (err-file (jka-compr-make-temp-name))
1522               (cur (current-buffer))
1523               (coding-system-for-read mm-binary-coding-system)
1524               (coding-system-for-write mm-binary-coding-system)
1525               retval err-msg)
1526           (message "%s" msg)
1527           (mm-with-unibyte-buffer
1528             (insert-buffer-substring cur)
1529             (condition-case err
1530                 (progn
1531                   (unless (memq (apply 'call-process-region
1532                                        (point-min) (point-max)
1533                                        prog t (list t err-file) nil args)
1534                                 jka-compr-acceptable-retval-list)
1535                     (erase-buffer)
1536                     (insert (mapconcat 'identity
1537                                        (split-string
1538                                         (prog2
1539                                             (insert-file-contents err-file)
1540                                             (buffer-string)
1541                                           (erase-buffer)) t)
1542                                        " ")
1543                             "\n")
1544                     (setq err-msg
1545                           (format "Error while executing \"%s %s < %s\""
1546                                   prog (mapconcat 'identity args " ")
1547                                   filename)))
1548                   (setq retval (buffer-string)))
1549               (error
1550                (setq err-msg (error-message-string err)))))
1551           (when (file-exists-p err-file)
1552             (ignore-errors (delete-file err-file)))
1553           (when inplace
1554             (unless err-msg
1555               (delete-region (point-min) (point-max))
1556               (insert retval))
1557             (setq retval nil))
1558           (message "%s" (or err-msg (concat msg "done")))
1559           retval)))))
1560
1561 (eval-when-compile
1562   (unless (fboundp 'coding-system-name)
1563     (defalias 'coding-system-name 'ignore))
1564   (unless (fboundp 'find-file-coding-system-for-read-from-filename)
1565     (defalias 'find-file-coding-system-for-read-from-filename 'ignore))
1566   (unless (fboundp 'find-operation-coding-system)
1567     (defalias 'find-operation-coding-system 'ignore)))
1568
1569 (defun mm-find-buffer-file-coding-system (&optional filename)
1570   "Find coding system used to decode the contents of the current buffer.
1571 This function looks for the coding system magic cookie or examines the
1572 coding system specified by `file-coding-system-alist' being associated
1573 with FILENAME which defaults to `buffer-file-name'.  Data compressed by
1574 gzip, bzip2, etc. are allowed."
1575   (unless filename
1576     (setq filename buffer-file-name))
1577   (save-excursion
1578     (let ((decomp (unless ;; No worth to examine charset of tar files.
1579                       (and filename
1580                            (string-match
1581                             "\\.\\(?:tar\\.[^.]+\\|tbz\\|tgz\\)\\'"
1582                             filename))
1583                     (mm-decompress-buffer filename nil t))))
1584       (when decomp
1585         (set-buffer (generate-new-buffer " *temp*"))
1586         (mm-disable-multibyte)
1587         (insert decomp)
1588         (setq filename (file-name-sans-extension filename)))
1589       (goto-char (point-min))
1590       (prog1
1591           (cond
1592            ((boundp 'set-auto-coding-function) ;; Emacs
1593             (if filename
1594                 (or (funcall (symbol-value 'set-auto-coding-function)
1595                              filename (- (point-max) (point-min)))
1596                     (car (find-operation-coding-system 'insert-file-contents
1597                                                        filename)))
1598               (let (auto-coding-alist)
1599                 (condition-case nil
1600                     (funcall (symbol-value 'set-auto-coding-function)
1601                              nil (- (point-max) (point-min)))
1602                   (error nil)))))
1603            ((and (featurep 'xemacs) (featurep 'file-coding)) ;; XEmacs
1604             (let ((case-fold-search t)
1605                   (end (point-at-eol))
1606                   codesys start)
1607               (or
1608                (and (re-search-forward "-\\*-+[\t ]*" end t)
1609                     (progn
1610                       (setq start (match-end 0))
1611                       (re-search-forward "[\t ]*-+\\*-" end t))
1612                     (progn
1613                       (setq end (match-beginning 0))
1614                       (goto-char start)
1615                       (or (looking-at "coding:[\t ]*\\([^\t ;]+\\)")
1616                           (re-search-forward
1617                            "[\t ;]+coding:[\t ]*\\([^\t ;]+\\)"
1618                            end t)))
1619                     (find-coding-system (setq codesys
1620                                               (intern (match-string 1))))
1621                     codesys)
1622                (and (re-search-forward "^[\t ]*;+[\t ]*Local[\t ]+Variables:"
1623                                        nil t)
1624                     (progn
1625                       (setq start (match-end 0))
1626                       (re-search-forward "^[\t ]*;+[\t ]*End:" nil t))
1627                     (progn
1628                       (setq end (match-beginning 0))
1629                       (goto-char start)
1630                       (re-search-forward
1631                        "^[\t ]*;+[\t ]*coding:[\t ]*\\([^\t\n\r ]+\\)"
1632                        end t))
1633                     (find-coding-system (setq codesys
1634                                               (intern (match-string 1))))
1635                     codesys)
1636                (and (progn
1637                       (goto-char (point-min))
1638                       (setq case-fold-search nil)
1639                       (re-search-forward "^;;;coding system: "
1640                                          ;;(+ (point-min) 3000) t))
1641                                          nil t))
1642                     (looking-at "[^\t\n\r ]+")
1643                     (find-coding-system
1644                      (setq codesys (intern (match-string 0))))
1645                     codesys)
1646                (and filename
1647                     (setq codesys
1648                           (find-file-coding-system-for-read-from-filename
1649                            filename))
1650                     (coding-system-name (coding-system-base codesys)))))))
1651         (when decomp
1652           (kill-buffer (current-buffer)))))))
1653
1654 (provide 'mm-util)
1655
1656 ;;; mm-util.el ends here