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