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 ;; `delete-dups' is not available in XEmacs 21.4.
 978 (if (fboundp 'delete-dups)
 979     (defalias 'mm-delete-duplicates 'delete-dups)
 980   (defun mm-delete-duplicates (list)
 981     "Destructively remove `equal' duplicates from LIST.
 982 Store the result in LIST and return it.  LIST must be a proper list.
 983 Of several `equal' occurrences of an element in LIST, the first
 984 one is kept.
 985
 986 This is a compatibility function for Emacsen without `delete-dups'."
 987     ;; Code from `subr.el' in Emacs 22:
 988     (let ((tail list))
 989       (while tail
 990         (setcdr tail (delete (car tail) (cdr tail)))
 991         (setq tail (cdr tail))))
 992     list))
 993
 994 ;; Fixme:  This is used in places when it should be testing the
 995 ;; default multibyteness.  See mm-default-multibyte-p.
 996 (eval-and-compile
 997   (if (and (not (featurep 'xemacs))
 998            (boundp 'enable-multibyte-characters))
 999       (defun mm-multibyte-p ()
1000         "Non-nil if multibyte is enabled in the current buffer."
1001         enable-multibyte-characters)
1002     (defun mm-multibyte-p () (featurep 'mule))))
1003
1004 (defun mm-default-multibyte-p ()
1005   "Return non-nil if the session is multibyte.
1006 This affects whether coding conversion should be attempted generally."
1007   (if (featurep 'mule)
1008       (if (boundp 'enable-multibyte-characters)
1009           (default-value 'enable-multibyte-characters)
1010         t)))
1011
1012 (defun mm-iso-8859-x-to-15-region (&optional b e)
1013   (if (fboundp 'char-charset)
1014       (let (charset item c inconvertible)
1015         (save-restriction
1016           (if e (narrow-to-region b e))
1017           (goto-char (point-min))
1018           (skip-chars-forward "\0-\177")
1019           (while (not (eobp))
1020             (cond
1021              ((not (setq item (assq (char-charset (setq c (char-after)))
1022                                     mm-iso-8859-x-to-15-table)))
1023               (forward-char))
1024              ((memq c (cdr (cdr item)))
1025               (setq inconvertible t)
1026               (forward-char))
1027              (t
1028               (insert-before-markers (prog1 (+ c (car (cdr item)))
1029                                        (delete-char 1)))))
1030             (skip-chars-forward "\0-\177")))
1031         (not inconvertible))))
1032
1033 (defun mm-sort-coding-systems-predicate (a b)
1034   (let ((priorities
1035          (mapcar (lambda (cs)
1036                    ;; Note: invalid entries are dropped silently
1037                    (and (setq cs (mm-coding-system-p cs))
1038                         (coding-system-base cs)))
1039                  mm-coding-system-priorities)))
1040     (and (setq a (mm-coding-system-p a))
1041          (if (setq b (mm-coding-system-p b))
1042              (> (length (memq (coding-system-base a) priorities))
1043                 (length (memq (coding-system-base b) priorities)))
1044            t))))
1045
1046 (eval-when-compile
1047   (autoload 'latin-unity-massage-name "latin-unity")
1048   (autoload 'latin-unity-maybe-remap "latin-unity")
1049   (autoload 'latin-unity-representations-feasible-region "latin-unity")
1050   (autoload 'latin-unity-representations-present-region "latin-unity"))
1051
1052 (defvar latin-unity-coding-systems)
1053 (defvar latin-unity-ucs-list)
1054
1055 (defun mm-xemacs-find-mime-charset-1 (begin end)
1056   "Determine which MIME charset to use to send region as message.
1057 This uses the XEmacs-specific latin-unity package to better handle the
1058 case where identical characters from diverse ISO-8859-? character sets
1059 can be encoded using a single one of the corresponding coding systems.
1060
1061 It treats `mm-coding-system-priorities' as the list of preferred
1062 coding systems; a useful example setting for this list in Western
1063 Europe would be '(iso-8859-1 iso-8859-15 utf-8), which would default
1064 to the very standard Latin 1 coding system, and only move to coding
1065 systems that are less supported as is necessary to encode the
1066 characters that exist in the buffer.
1067
1068 Latin Unity doesn't know about those non-ASCII Roman characters that
1069 are available in various East Asian character sets.  As such, its
1070 behavior if you have a JIS 0212 LATIN SMALL LETTER A WITH ACUTE in a
1071 buffer and it can otherwise be encoded as Latin 1, won't be ideal.
1072 But this is very much a corner case, so don't worry about it."
1073   (let ((systems mm-coding-system-priorities) csets psets curset)
1074
1075     ;; Load the Latin Unity library, if available.
1076     (when (and (not (featurep 'latin-unity)) (locate-library "latin-unity"))
1077       (require 'latin-unity))
1078
1079     ;; Now, can we use it?
1080     (if (featurep 'latin-unity)
1081         (progn
1082           (setq csets (latin-unity-representations-feasible-region begin end)
1083                 psets (latin-unity-representations-present-region begin end))
1084
1085           (catch 'done
1086
1087             ;; Pass back the first coding system in the preferred list
1088             ;; that can encode the whole region.
1089             (dolist (curset systems)
1090               (setq curset (latin-unity-massage-name 'buffer-default curset))
1091
1092               ;; If the coding system is a universal coding system, then
1093               ;; it can certainly encode all the characters in the region.
1094               (if (memq curset latin-unity-ucs-list)
1095                   (throw 'done (list curset)))
1096
1097               ;; If a coding system isn't universal, and isn't in
1098               ;; the list that latin unity knows about, we can't
1099               ;; decide whether to use it here. Leave that until later
1100               ;; in `mm-find-mime-charset-region' function, whence we
1101               ;; have been called.
1102               (unless (memq curset latin-unity-coding-systems)
1103                 (throw 'done nil))
1104
1105               ;; Right, we know about this coding system, and it may
1106               ;; conceivably be able to encode all the characters in
1107               ;; the region.
1108               (if (latin-unity-maybe-remap begin end curset csets psets t)
1109                   (throw 'done (list curset))))
1110
1111             ;; Can't encode using anything from the
1112             ;; `mm-coding-system-priorities' list.
1113             ;; Leave `mm-find-mime-charset' to do most of the work.
1114             nil))
1115
1116       ;; Right, latin unity isn't available; let `mm-find-charset-region'
1117       ;; take its default action, which equally applies to GNU Emacs.
1118       nil)))
1119
1120 (defmacro mm-xemacs-find-mime-charset (begin end)
1121   (when (featurep 'xemacs)
1122     `(and (featurep 'mule) (mm-xemacs-find-mime-charset-1 ,begin ,end))))
1123
1124 (declare-function mm-delete-duplicates "mm-util" (list))
1125
1126 (defun mm-find-mime-charset-region (b e &optional hack-charsets)
1127   "Return the MIME charsets needed to encode the region between B and E.
1128 nil means ASCII, a single-element list represents an appropriate MIME
1129 charset, and a longer list means no appropriate charset."
1130   (let (charsets)
1131     ;; The return possibilities of this function are a mess...
1132     (or (and (mm-multibyte-p)
1133              mm-use-find-coding-systems-region
1134              ;; Find the mime-charset of the most preferred coding
1135              ;; system that has one.
1136              (let ((systems (find-coding-systems-region b e)))
1137                (when mm-coding-system-priorities
1138                  (setq systems
1139                        (sort systems 'mm-sort-coding-systems-predicate)))
1140                (setq systems (delq 'compound-text systems))
1141                (unless (equal systems '(undecided))
1142                  (while systems
1143                    (let* ((head (pop systems))
1144                           (cs (or (coding-system-get head :mime-charset)
1145                                   (coding-system-get head 'mime-charset))))
1146                      ;; The mime-charset (`x-ctext') of
1147                      ;; `compound-text' is not in the IANA list.  We
1148                      ;; shouldn't normally use anything here with a
1149                      ;; mime-charset having an `x-' prefix.
1150                      ;; Fixme:  Allow this to be overridden, since
1151                      ;; there is existing use of x-ctext.
1152                      ;; Also people apparently need the coding system
1153                      ;; `iso-2022-jp-3' (which Mule-UCS defines with
1154                      ;; mime-charset, though it's not valid).
1155                      (if (and cs
1156                               (not (string-match "^[Xx]-" (symbol-name cs)))
1157                               ;; UTF-16 of any variety is invalid for
1158                               ;; text parts and, unfortunately, has
1159                               ;; mime-charset defined both in Mule-UCS
1160                               ;; and versions of Emacs.  (The name
1161                               ;; might be `mule-utf-16...'  or
1162                               ;; `utf-16...'.)
1163                               (not (string-match "utf-16" (symbol-name cs))))
1164                          (setq systems nil
1165                                charsets (list cs))))))
1166                charsets))
1167         ;; If we're XEmacs, and some coding system is appropriate,
1168         ;; mm-xemacs-find-mime-charset will return an appropriate list.
1169         ;; Otherwise, we'll get nil, and the next setq will get invoked.
1170         (setq charsets (mm-xemacs-find-mime-charset b e))
1171
1172         ;; Fixme: won't work for unibyte Emacs 23:
1173
1174         ;; We're not multibyte, or a single coding system won't cover it.
1175         (setq charsets
1176               (mm-delete-duplicates
1177                (mapcar 'mm-mime-charset
1178                        (delq 'ascii
1179                              (mm-find-charset-region b e))))))
1180     (if (and (> (length charsets) 1)
1181              (memq 'iso-8859-15 charsets)
1182              (memq 'iso-8859-15 hack-charsets)
1183              (save-excursion (mm-iso-8859-x-to-15-region b e)))
1184         (dolist (x mm-iso-8859-15-compatible)
1185           (setq charsets (delq (car x) charsets))))
1186     (if (and (memq 'iso-2022-jp-2 charsets)
1187              (memq 'iso-2022-jp-2 hack-charsets))
1188         (setq charsets (delq 'iso-2022-jp charsets)))
1189     ;; Attempt to reduce the number of charsets if utf-8 is available.
1190     (if (and (featurep 'xemacs)
1191              (> (length charsets) 1)
1192              (mm-coding-system-p 'utf-8))
1193         (let ((mm-coding-system-priorities
1194                (cons 'utf-8 mm-coding-system-priorities)))
1195           (setq charsets
1196                 (mm-delete-duplicates
1197                  (mapcar 'mm-mime-charset
1198                          (delq 'ascii
1199                                (mm-find-charset-region b e)))))))
1200     charsets))
1201
1202 (defmacro mm-with-unibyte-buffer (&rest forms)
1203   "Create a temporary buffer, and evaluate FORMS there like `progn'.
1204 Use unibyte mode for this."
1205   `(with-temp-buffer
1206      (mm-disable-multibyte)
1207      ,@forms))
1208 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
1209 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
1210
1211 (defmacro mm-with-multibyte-buffer (&rest forms)
1212   "Create a temporary buffer, and evaluate FORMS there like `progn'.
1213 Use multibyte mode for this."
1214   `(with-temp-buffer
1215      (mm-enable-multibyte)
1216      ,@forms))
1217 (put 'mm-with-multibyte-buffer 'lisp-indent-function 0)
1218 (put 'mm-with-multibyte-buffer 'edebug-form-spec '(body))
1219
1220 (defmacro mm-with-unibyte-current-buffer (&rest forms)
1221   "Evaluate FORMS with current buffer temporarily made unibyte.
1222 Equivalent to `progn' in XEmacs.
1223
1224 Note: We recommend not using this macro any more; there should be
1225 better ways to do a similar thing.  The previous version of this macro
1226 bound the default value of `enable-multibyte-characters' to nil while
1227 evaluating FORMS but it is no longer done.  So, some programs assuming
1228 it if any may malfunction."
1229   (if (featurep 'xemacs)
1230       `(progn ,@forms)
1231     (let ((multibyte (make-symbol "multibyte")))
1232       `(let ((,multibyte enable-multibyte-characters))
1233          (when ,multibyte
1234            (set-buffer-multibyte nil))
1235          (prog1
1236              (progn ,@forms)
1237            (when ,multibyte
1238              (set-buffer-multibyte t)))))))
1239 (put 'mm-with-unibyte-current-buffer 'lisp-indent-function 0)
1240 (put 'mm-with-unibyte-current-buffer 'edebug-form-spec '(body))
1241
1242 (defun mm-find-charset-region (b e)
1243   "Return a list of Emacs charsets in the region B to E."
1244   (cond
1245    ((and (mm-multibyte-p)
1246          (fboundp 'find-charset-region))
1247     ;; Remove composition since the base charsets have been included.
1248     ;; Remove eight-bit-*, treat them as ascii.
1249     (let ((css (find-charset-region b e)))
1250       (dolist (cs
1251                '(composition eight-bit-control eight-bit-graphic control-1)
1252                css)
1253         (setq css (delq cs css)))))
1254    (t
1255     ;; We are in a unibyte buffer or XEmacs non-mule, so we futz around a bit.
1256     (save-excursion
1257       (save-restriction
1258         (narrow-to-region b e)
1259         (goto-char (point-min))
1260         (skip-chars-forward "\0-\177")
1261         (if (eobp)
1262             '(ascii)
1263           (let (charset)
1264             (setq charset
1265                   (and (boundp 'current-language-environment)
1266                        (car (last (assq 'charset
1267                                         (assoc current-language-environment
1268                                                language-info-alist))))))
1269             (if (eq charset 'ascii) (setq charset nil))
1270             (or charset
1271                 (setq charset
1272                       (car (last (assq mail-parse-charset
1273                                        mm-mime-mule-charset-alist)))))
1274             (list 'ascii (or charset 'latin-iso8859-1)))))))))
1275
1276 (defun mm-auto-mode-alist ()
1277   "Return an `auto-mode-alist' with only the .gz (etc) thingies."
1278   (let ((alist auto-mode-alist)
1279         out)
1280     (while alist
1281       (when (listp (cdar alist))
1282         (push (car alist) out))
1283       (pop alist))
1284     (nreverse out)))
1285
1286 (defvar mm-inhibit-file-name-handlers
1287   '(jka-compr-handler image-file-handler epa-file-handler)
1288   "A list of handlers doing (un)compression (etc) thingies.")
1289
1290 (defun mm-insert-file-contents (filename &optional visit beg end replace
1291                                          inhibit)
1292   "Like `insert-file-contents', but only reads in the file.
1293 A buffer may be modified in several ways after reading into the buffer due
1294 to advanced Emacs features, such as file-name-handlers, format decoding,
1295 `find-file-hooks', etc.
1296 If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'.
1297   This function ensures that none of these modifications will take place."
1298   (letf* ((format-alist nil)
1299           (auto-mode-alist (if inhibit nil (mm-auto-mode-alist)))
1300           ((default-value 'major-mode) 'fundamental-mode)
1301           (enable-local-variables nil)
1302           (after-insert-file-functions nil)
1303           (enable-local-eval nil)
1304           (inhibit-file-name-operation (if inhibit
1305                                            'insert-file-contents
1306                                          inhibit-file-name-operation))
1307           (inhibit-file-name-handlers
1308            (if inhibit
1309                (append mm-inhibit-file-name-handlers
1310                        inhibit-file-name-handlers)
1311              inhibit-file-name-handlers))
1312           (ffh (if (boundp 'find-file-hook)
1313                    'find-file-hook
1314                  'find-file-hooks))
1315           (val (symbol-value ffh)))
1316     (set ffh nil)
1317     (unwind-protect
1318         (insert-file-contents filename visit beg end replace)
1319       (set ffh val))))
1320
1321 (defun mm-append-to-file (start end filename &optional codesys inhibit)
1322   "Append the contents of the region to the end of file FILENAME.
1323 When called from a function, expects three arguments,
1324 START, END and FILENAME.  START and END are buffer positions
1325 saying what text to write.
1326 Optional fourth argument specifies the coding system to use when
1327 encoding the file.
1328 If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'."
1329   (let ((coding-system-for-write
1330          (or codesys mm-text-coding-system-for-write
1331              mm-text-coding-system))
1332         (inhibit-file-name-operation (if inhibit
1333                                          'append-to-file
1334                                        inhibit-file-name-operation))
1335         (inhibit-file-name-handlers
1336          (if inhibit
1337              (append mm-inhibit-file-name-handlers
1338                      inhibit-file-name-handlers)
1339            inhibit-file-name-handlers)))
1340     (write-region start end filename t 'no-message)
1341     (message "Appended to %s" filename)))
1342
1343 (defun mm-write-region (start end filename &optional append visit lockname
1344                               coding-system inhibit)
1345
1346   "Like `write-region'.
1347 If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'."
1348   (let ((coding-system-for-write
1349          (or coding-system mm-text-coding-system-for-write
1350              mm-text-coding-system))
1351         (inhibit-file-name-operation (if inhibit
1352                                          'write-region
1353                                        inhibit-file-name-operation))
1354         (inhibit-file-name-handlers
1355          (if inhibit
1356              (append mm-inhibit-file-name-handlers
1357                      inhibit-file-name-handlers)
1358            inhibit-file-name-handlers)))
1359     (write-region start end filename append visit lockname)))
1360
1361 (autoload 'gmm-write-region "gmm-utils")
1362
1363 ;; It is not a MIME function, but some MIME functions use it.
1364 (if (and (fboundp 'make-temp-file)
1365          (ignore-errors
1366            (let ((def (symbol-function 'make-temp-file)))
1367              (and (byte-code-function-p def)
1368                   (setq def (if (fboundp 'compiled-function-arglist)
1369                                 ;; XEmacs
1370                                 (eval (list 'compiled-function-arglist def))
1371                               (aref def 0)))
1372                   (>= (length def) 4)
1373                   (eq (nth 3 def) 'suffix)))))
1374     (defalias 'mm-make-temp-file 'make-temp-file)
1375   ;; Stolen (and modified for XEmacs) from Emacs 22.
1376   (defun mm-make-temp-file (prefix &optional dir-flag suffix)
1377     "Create a temporary file.
1378 The returned file name (created by appending some random characters at the end
1379 of PREFIX, and expanding against `temporary-file-directory' if necessary),
1380 is guaranteed to point to a newly created empty file.
1381 You can then use `write-region' to write new data into the file.
1382
1383 If DIR-FLAG is non-nil, create a new empty directory instead of a file.
1384
1385 If SUFFIX is non-nil, add that at the end of the file name."
1386     (let ((umask (default-file-modes))
1387           file)
1388       (unwind-protect
1389           (progn
1390             ;; Create temp files with strict access rights.  It's easy to
1391             ;; loosen them later, whereas it's impossible to close the
1392             ;; time-window of loose permissions otherwise.
1393             (set-default-file-modes 448)
1394             (while (condition-case err
1395                        (progn
1396                          (setq file
1397                                (make-temp-name
1398                                 (expand-file-name
1399                                  prefix
1400                                  (if (fboundp 'temp-directory)
1401                                      ;; XEmacs
1402                                      (temp-directory)
1403                                    temporary-file-directory))))
1404                          (if suffix
1405                              (setq file (concat file suffix)))
1406                          (if dir-flag
1407                              (make-directory file)
1408                            ;; NOTE: This is unsafe if Emacs 20
1409                            ;; users and XEmacs users don't use
1410                            ;; a secure temp directory.
1411                            (gmm-write-region "" nil file nil 'silent
1412                                              nil 'excl))
1413                          nil)
1414                      (file-already-exists t)
1415                      ;; The XEmacs version of `make-directory' issues
1416                      ;; `file-error'.
1417                      (file-error (or (and (featurep 'xemacs)
1418                                           (file-exists-p file))
1419                                      (signal (car err) (cdr err)))))
1420               ;; the file was somehow created by someone else between
1421               ;; `make-temp-name' and `write-region', let's try again.
1422               nil)
1423             file)
1424         ;; Reset the umask.
1425         (set-default-file-modes umask)))))
1426
1427 (defvar mm-image-load-path-cache nil)
1428
1429 (defun mm-image-load-path (&optional package)
1430   (if (and mm-image-load-path-cache
1431            (equal load-path (car mm-image-load-path-cache)))
1432       (cdr mm-image-load-path-cache)
1433     (let (dir result)
1434       (dolist (path load-path)
1435         (when (and path
1436                    (file-directory-p
1437                     (setq dir (concat (file-name-directory
1438                                        (directory-file-name path))
1439                                       "etc/images/" (or package "gnus/")))))
1440           (push dir result)))
1441       (setq result (nreverse result)
1442             mm-image-load-path-cache (cons load-path result))
1443       result)))
1444
1445 ;; Fixme: This doesn't look useful where it's used.
1446 (if (fboundp 'detect-coding-region)
1447     (defun mm-detect-coding-region (start end)
1448       "Like `detect-coding-region' except returning the best one."
1449       (let ((coding-systems
1450              (detect-coding-region start end)))
1451         (or (car-safe coding-systems)
1452             coding-systems)))
1453   (defun mm-detect-coding-region (start end)
1454     (let ((point (point)))
1455       (goto-char start)
1456       (skip-chars-forward "\0-\177" end)
1457       (prog1
1458           (if (eq (point) end) 'ascii (mm-guess-charset))
1459         (goto-char point)))))
1460
1461 (declare-function mm-detect-coding-region "mm-util" (start end))
1462
1463 (if (fboundp 'coding-system-get)
1464     (defun mm-detect-mime-charset-region (start end)
1465       "Detect MIME charset of the text in the region between START and END."
1466       (let ((cs (mm-detect-coding-region start end)))
1467         (or (coding-system-get cs :mime-charset)
1468             (coding-system-get cs 'mime-charset))))
1469   (defun mm-detect-mime-charset-region (start end)
1470     "Detect MIME charset of the text in the region between START and END."
1471     (let ((cs (mm-detect-coding-region start end)))
1472       cs)))
1473
1474 (eval-when-compile
1475   (unless (fboundp 'coding-system-to-mime-charset)
1476     (defalias 'coding-system-to-mime-charset 'ignore)))
1477
1478 (defun mm-coding-system-to-mime-charset (coding-system)
1479   "Return the MIME charset corresponding to CODING-SYSTEM.
1480 To make this function work with XEmacs, the APEL package is required."
1481   (when coding-system
1482     (or (and (fboundp 'coding-system-get)
1483              (or (coding-system-get coding-system :mime-charset)
1484                  (coding-system-get coding-system 'mime-charset)))
1485         (and (featurep 'xemacs)
1486              (or (and (fboundp 'coding-system-to-mime-charset)
1487                       (not (eq (symbol-function 'coding-system-to-mime-charset)
1488                                'ignore)))
1489                  (and (condition-case nil
1490                           (require 'mcharset)
1491                         (error nil))
1492                       (fboundp 'coding-system-to-mime-charset)))
1493              (coding-system-to-mime-charset coding-system)))))
1494
1495 (eval-when-compile
1496   (require 'jka-compr))
1497
1498 (defun mm-decompress-buffer (filename &optional inplace force)
1499   "Decompress buffer's contents, depending on jka-compr.
1500 Only when FORCE is t or `auto-compression-mode' is enabled and FILENAME
1501 agrees with `jka-compr-compression-info-list', decompression is done.
1502 Signal an error if FORCE is neither nil nor t and compressed data are
1503 not decompressed because `auto-compression-mode' is disabled.
1504 If INPLACE is nil, return decompressed data or nil without modifying
1505 the buffer.  Otherwise, replace the buffer's contents with the
1506 decompressed data.  The buffer's multibyteness must be turned off."
1507   (when (and filename
1508              (if force
1509                  (prog1 t (require 'jka-compr))
1510                (and (fboundp 'jka-compr-installed-p)
1511                     (jka-compr-installed-p))))
1512     (let ((info (jka-compr-get-compression-info filename)))
1513       (when info
1514         (unless (or (memq force (list nil t))
1515                     (jka-compr-installed-p))
1516           (error ""))
1517         (let ((prog (jka-compr-info-uncompress-program info))
1518               (args (jka-compr-info-uncompress-args info))
1519               (msg (format "%s %s..."
1520                            (jka-compr-info-uncompress-message info)
1521                            filename))
1522               (err-file (jka-compr-make-temp-name))
1523               (cur (current-buffer))
1524               (coding-system-for-read mm-binary-coding-system)
1525               (coding-system-for-write mm-binary-coding-system)
1526               retval err-msg)
1527           (message "%s" msg)
1528           (mm-with-unibyte-buffer
1529             (insert-buffer-substring cur)
1530             (condition-case err
1531                 (progn
1532                   (unless (memq (apply 'call-process-region
1533                                        (point-min) (point-max)
1534                                        prog t (list t err-file) nil args)
1535                                 jka-compr-acceptable-retval-list)
1536                     (erase-buffer)
1537                     (insert (mapconcat 'identity
1538                                        (split-string
1539                                         (prog2
1540                                             (insert-file-contents err-file)
1541                                             (buffer-string)
1542                                           (erase-buffer)) t)
1543                                        " ")
1544                             "\n")
1545                     (setq err-msg
1546                           (format "Error while executing \"%s %s < %s\""
1547                                   prog (mapconcat 'identity args " ")
1548                                   filename)))
1549                   (setq retval (buffer-string)))
1550               (error
1551                (setq err-msg (error-message-string err)))))
1552           (when (file-exists-p err-file)
1553             (ignore-errors (delete-file err-file)))
1554           (when inplace
1555             (unless err-msg
1556               (delete-region (point-min) (point-max))
1557               (insert retval))
1558             (setq retval nil))
1559           (message "%s" (or err-msg (concat msg "done")))
1560           retval)))))
1561
1562 (eval-when-compile
1563   (unless (fboundp 'coding-system-name)
1564     (defalias 'coding-system-name 'ignore))
1565   (unless (fboundp 'find-file-coding-system-for-read-from-filename)
1566     (defalias 'find-file-coding-system-for-read-from-filename 'ignore))
1567   (unless (fboundp 'find-operation-coding-system)
1568     (defalias 'find-operation-coding-system 'ignore)))
1569
1570 (defun mm-find-buffer-file-coding-system (&optional filename)
1571   "Find coding system used to decode the contents of the current buffer.
1572 This function looks for the coding system magic cookie or examines the
1573 coding system specified by `file-coding-system-alist' being associated
1574 with FILENAME which defaults to `buffer-file-name'.  Data compressed by
1575 gzip, bzip2, etc. are allowed."
1576   (unless filename
1577     (setq filename buffer-file-name))
1578   (save-excursion
1579     (let ((decomp (unless ;; No worth to examine charset of tar files.
1580                       (and filename
1581                            (string-match
1582                             "\\.\\(?:tar\\.[^.]+\\|tbz\\|tgz\\)\\'"
1583                             filename))
1584                     (mm-decompress-buffer filename nil t))))
1585       (when decomp
1586         (set-buffer (generate-new-buffer " *temp*"))
1587         (mm-disable-multibyte)
1588         (insert decomp)
1589         (setq filename (file-name-sans-extension filename)))
1590       (goto-char (point-min))
1591       (prog1
1592           (cond
1593            ((boundp 'set-auto-coding-function) ;; Emacs
1594             (if filename
1595                 (or (funcall (symbol-value 'set-auto-coding-function)
1596                              filename (- (point-max) (point-min)))
1597                     (car (find-operation-coding-system 'insert-file-contents
1598                                                        filename)))
1599               (let (auto-coding-alist)
1600                 (condition-case nil
1601                     (funcall (symbol-value 'set-auto-coding-function)
1602                              nil (- (point-max) (point-min)))
1603                   (error nil)))))
1604            ((and (featurep 'xemacs) (featurep 'file-coding)) ;; XEmacs
1605             (let ((case-fold-search t)
1606                   (end (point-at-eol))
1607                   codesys start)
1608               (or
1609                (and (re-search-forward "-\\*-+[\t ]*" end t)
1610                     (progn
1611                       (setq start (match-end 0))
1612                       (re-search-forward "[\t ]*-+\\*-" end t))
1613                     (progn
1614                       (setq end (match-beginning 0))
1615                       (goto-char start)
1616                       (or (looking-at "coding:[\t ]*\\([^\t ;]+\\)")
1617                           (re-search-forward
1618                            "[\t ;]+coding:[\t ]*\\([^\t ;]+\\)"
1619                            end t)))
1620                     (find-coding-system (setq codesys
1621                                               (intern (match-string 1))))
1622                     codesys)
1623                (and (re-search-forward "^[\t ]*;+[\t ]*Local[\t ]+Variables:"
1624                                        nil t)
1625                     (progn
1626                       (setq start (match-end 0))
1627                       (re-search-forward "^[\t ]*;+[\t ]*End:" nil t))
1628                     (progn
1629                       (setq end (match-beginning 0))
1630                       (goto-char start)
1631                       (re-search-forward
1632                        "^[\t ]*;+[\t ]*coding:[\t ]*\\([^\t\n\r ]+\\)"
1633                        end t))
1634                     (find-coding-system (setq codesys
1635                                               (intern (match-string 1))))
1636                     codesys)
1637                (and (progn
1638                       (goto-char (point-min))
1639                       (setq case-fold-search nil)
1640                       (re-search-forward "^;;;coding system: "
1641                                          ;;(+ (point-min) 3000) t))
1642                                          nil t))
1643                     (looking-at "[^\t\n\r ]+")
1644                     (find-coding-system
1645                      (setq codesys (intern (match-string 0))))
1646                     codesys)
1647                (and filename
1648                     (setq codesys
1649                           (find-file-coding-system-for-read-from-filename
1650                            filename))
1651                     (coding-system-name (coding-system-base codesys)))))))
1652         (when decomp
1653           (kill-buffer (current-buffer)))))))
1654
1655 (provide 'mm-util)
1656
1657 ;;; mm-util.el ends here