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,
   4 ;;   2005 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 2, or (at your option)
  13 ;; 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; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (eval-when-compile (require 'cl))
  30 (require 'mail-prsvr)
  31
  32 (eval-and-compile
  33   (mapcar
  34    (lambda (elem)
  35      (let ((nfunc (intern (format "mm-%s" (car elem)))))
  36        (if (fboundp (car elem))
  37            (defalias nfunc (car elem))
  38          (defalias nfunc (cdr elem)))))
  39    '((decode-coding-string . (lambda (s a) s))
  40      (encode-coding-string . (lambda (s a) s))
  41      (encode-coding-region . ignore)
  42      (coding-system-list . ignore)
  43      (decode-coding-region . ignore)
  44      (char-int . identity)
  45      (coding-system-equal . equal)
  46      (annotationp . ignore)
  47      (set-buffer-file-coding-system . ignore)
  48      (read-charset
  49       . (lambda (prompt)
  50           "Return a charset."
  51           (intern
  52            (completing-read
  53             prompt
  54             (mapcar (lambda (e) (list (symbol-name (car e))))
  55                     mm-mime-mule-charset-alist)
  56             nil t))))
  57      (subst-char-in-string
  58       . (lambda (from to string &optional inplace)
  59           ;; stolen (and renamed) from nnheader.el
  60           "Replace characters in STRING from FROM to TO.
  61           Unless optional argument INPLACE is non-nil, return a new string."
  62           (let ((string (if inplace string (copy-sequence string)))
  63                 (len (length string))
  64                 (idx 0))
  65             ;; Replace all occurrences of FROM with TO.
  66             (while (< idx len)
  67               (when (= (aref string idx) from)
  68                 (aset string idx to))
  69               (setq idx (1+ idx)))
  70             string)))
  71      (replace-in-string
  72       . (lambda (string regexp rep &optional literal)
  73           "See `replace-regexp-in-string', only the order of args differs."
  74           (replace-regexp-in-string regexp rep string nil literal)))
  75      (string-as-unibyte . identity)
  76      (string-make-unibyte . identity)
  77      ;; string-as-multibyte often doesn't really do what you think it does.
  78      ;; Example:
  79      ;;    (aref (string-as-multibyte "\201") 0) -> 129 (aka ?\201)
  80      ;;    (aref (string-as-multibyte "\300") 0) -> 192 (aka ?\300)
  81      ;;    (aref (string-as-multibyte "\300\201") 0) -> 192 (aka ?\300)
  82      ;;    (aref (string-as-multibyte "\300\201") 1) -> 129 (aka ?\201)
  83      ;; but
  84      ;;    (aref (string-as-multibyte "\201\300") 0) -> 2240
  85      ;;    (aref (string-as-multibyte "\201\300") 1) -> <error>
  86      ;; Better use string-to-multibyte or encode-coding-string.
  87      ;; If you really need string-as-multibyte somewhere it's usually
  88      ;; because you're using the internal emacs-mule representation (maybe
  89      ;; because you're using string-as-unibyte somewhere), which is
  90      ;; generally a problem in itself.
  91      ;; Here is an approximate equivalence table to help think about it:
  92      ;; (string-as-multibyte s)   ~= (decode-coding-string s 'emacs-mule)
  93      ;; (string-to-multibyte s)   ~= (decode-coding-string s 'binary)
  94      ;; (string-make-multibyte s) ~= (decode-coding-string s locale-coding-system)
  95      (string-as-multibyte . identity)
  96      (string-to-multibyte
  97       . (lambda (string)
  98           "Return a multibyte string with the same individual chars as string."
  99           (mapconcat
 100            (lambda (ch) (mm-string-as-multibyte (char-to-string ch)))
 101            string "")))
 102      (multibyte-string-p . ignore)
 103      ;; It is not a MIME function, but some MIME functions use it.
 104      (make-temp-file . (lambda (prefix &optional dir-flag)
 105                          (let ((file (expand-file-name
 106                                       (make-temp-name prefix)
 107                                       (if (fboundp 'temp-directory)
 108                                           (temp-directory)
 109                                         temporary-file-directory))))
 110                            (if dir-flag
 111                                (make-directory file))
 112                            file)))
 113      (insert-byte . insert-char)
 114      (multibyte-char-to-unibyte . identity)
 115      (special-display-p
 116       . (lambda (buffer-name)
 117           "Returns non-nil if a buffer named BUFFER-NAME gets a special frame."
 118           (and special-display-function
 119                (or (and (member buffer-name special-display-buffer-names) t)
 120                    (cdr (assoc buffer-name special-display-buffer-names))
 121                    (catch 'return
 122                      (dolist (elem special-display-regexps)
 123                        (and (stringp elem)
 124                             (string-match elem buffer-name)
 125                             (throw 'return t))
 126                        (and (consp elem)
 127                             (stringp (car elem))
 128                             (string-match (car elem) buffer-name)
 129                             (throw 'return (cdr elem))))))))))))
 130
 131 (eval-and-compile
 132   (defalias 'mm-char-or-char-int-p
 133     (cond
 134      ((fboundp 'char-or-char-int-p) 'char-or-char-int-p)
 135      ((fboundp 'char-valid-p) 'char-valid-p)
 136      (t 'identity))))
 137
 138 ;; Fixme:  This seems always to be used to read a MIME charset, so it
 139 ;; should be re-named and fixed (in Emacs) to offer completion only on
 140 ;; proper charset names (base coding systems which have a
 141 ;; mime-charset defined).  XEmacs doesn't believe in mime-charset;
 142 ;; test with
 143 ;;   `(or (coding-system-get 'iso-8859-1 'mime-charset)
 144 ;;        (coding-system-get 'iso-8859-1 :mime-charset))'
 145 ;; Actually, there should be an `mm-coding-system-mime-charset'.
 146 (eval-and-compile
 147   (defalias 'mm-read-coding-system
 148     (cond
 149      ((fboundp 'read-coding-system)
 150       (if (and (featurep 'xemacs)
 151                (<= (string-to-number emacs-version) 21.1))
 152           (lambda (prompt &optional default-coding-system)
 153             (read-coding-system prompt))
 154         'read-coding-system))
 155      (t (lambda (prompt &optional default-coding-system)
 156           "Prompt the user for a coding system."
 157           (completing-read
 158            prompt (mapcar (lambda (s) (list (symbol-name (car s))))
 159                           mm-mime-mule-charset-alist)))))))
 160
 161 (defvar mm-coding-system-list nil)
 162 (defun mm-get-coding-system-list ()
 163   "Get the coding system list."
 164   (or mm-coding-system-list
 165       (setq mm-coding-system-list (mm-coding-system-list))))
 166
 167 (defun mm-coding-system-p (cs)
 168   "Return non-nil if CS is a symbol naming a coding system.
 169 In XEmacs, also return non-nil if CS is a coding system object.
 170 If CS is available, return CS itself in Emacs, and return a coding
 171 system object in XEmacs."
 172   (if (fboundp 'find-coding-system)
 173       (and cs (find-coding-system cs))
 174     (if (fboundp 'coding-system-p)
 175         (when (coding-system-p cs)
 176           cs)
 177       ;; Is this branch ever actually useful?
 178       (car (memq cs (mm-get-coding-system-list))))))
 179
 180 (defun mm-codepage-setup (number &optional alias)
 181   "Create a coding system cpNUMBER.
 182 The coding system is created using `codepage-setup'.  If ALIAS is
 183 non-nil, an alias is created and added to
 184 `mm-charset-synonym-alist'.  If ALIAS is a string, it's used as
 185 the alias.  Else windows-NUMBER is used."
 186   (interactive
 187    (let ((completion-ignore-case t)
 188          (candidates (cp-supported-codepages)))
 189      (list (completing-read "Setup DOS Codepage: (default 437) " candidates
 190                             nil t nil nil "437"))))
 191   (when alias
 192     (setq alias (if (stringp alias)
 193                     (intern alias)
 194                   (intern (format "windows-%s" number)))))
 195   (let* ((cp (intern (format "cp%s" number))))
 196     (unless (mm-coding-system-p cp)
 197       (codepage-setup number))
 198     (when (and alias
 199                ;; Don't add alias if setup of cp failed.
 200                (mm-coding-system-p cp))
 201       (add-to-list 'mm-charset-synonym-alist (cons alias cp)))))
 202
 203 (defvar mm-charset-synonym-alist
 204   `(
 205     ;; Not in XEmacs, but it's not a proper MIME charset anyhow.
 206     ,@(unless (mm-coding-system-p 'x-ctext)
 207        '((x-ctext . ctext)))
 208     ;; ISO-8859-15 is very similar to ISO-8859-1.  But it's _different_!
 209     ,@(unless (mm-coding-system-p 'iso-8859-15)
 210        '((iso-8859-15 . iso-8859-1)))
 211     ;; BIG-5HKSCS is similar to, but different than, BIG-5.
 212     ,@(unless (mm-coding-system-p 'big5-hkscs)
 213         '((big5-hkscs . big5)))
 214     ;; Windows-1252 is actually a superset of Latin-1.  See also
 215     ;; `gnus-article-dumbquotes-map'.
 216     ,@(unless (mm-coding-system-p 'windows-1252)
 217        (if (mm-coding-system-p 'cp1252)
 218            '((windows-1252 . cp1252))
 219          '((windows-1252 . iso-8859-1))))
 220     ;; Windows-1250 is a variant of Latin-2 heavily used by Microsoft
 221     ;; Outlook users in Czech republic. Use this to allow reading of their
 222     ;; e-mails. cp1250 should be defined by M-x codepage-setup.
 223     ,@(if (and (not (mm-coding-system-p 'windows-1250))
 224                (mm-coding-system-p 'cp1250))
 225           '((windows-1250 . cp1250)))
 226     ;; A Microsoft misunderstanding.
 227     ,@(if (and (not (mm-coding-system-p 'unicode))
 228                (mm-coding-system-p 'utf-16-le))
 229           '((unicode . utf-16-le)))
 230     ;; A Microsoft misunderstanding.
 231     ,@(unless (mm-coding-system-p 'ks_c_5601-1987)
 232         (if (mm-coding-system-p 'cp949)
 233             '((ks_c_5601-1987 . cp949))
 234           '((ks_c_5601-1987 . euc-kr))))
 235     )
 236   "A mapping from unknown or invalid charset names to the real charset names.")
 237
 238 (defcustom mm-charset-override-alist
 239   `((iso-8859-1 . windows-1252))
 240   "A mapping from undesired charset names to their replacement.
 241
 242 You may add pair like (iso-8859-1 . windows-1252) here,
 243 i.e. treat iso-8859-1 as windows-1252.  windows-1252 is a
 244 superset of iso-8859-1."
 245   :type '(list (set :inline t
 246                     (const (iso-8859-1 . windows-1252))
 247                     (const (undecided  . windows-1252)))
 248                (repeat :inline t
 249                        :tag "Other options"
 250                        (cons (symbol :tag "From charset")
 251                              (symbol :tag "To charset"))))
 252   :version "23.0" ;; No Gnus
 253   :group 'mime)
 254
 255 (defcustom mm-charset-eval-alist
 256   (if (featurep 'xemacs)
 257       nil ;; I don't know what would be useful for XEmacs.
 258     '(;; Emacs 21 offers 1250 1251 1253 1257.  Emacs 22 provides autoloads for
 259       ;; 1250-1258 (i.e. `mm-codepage-setup' does nothing).
 260       (windows-1250 . (mm-codepage-setup 1250 t))
 261       (windows-1251 . (mm-codepage-setup 1251 t))
 262       (windows-1253 . (mm-codepage-setup 1253 t))
 263       (windows-1257 . (mm-codepage-setup 1257 t))))
 264   "An alist of (CHARSET . FORM) pairs.
 265 If an article is encoded in an unknown CHARSET, FORM is
 266 evaluated.  This allows to load additional libraries providing
 267 charsets on demand.  If supported by your Emacs version, you
 268 could use `autoload-coding-system' here."
 269   :version "23.0" ;; No Gnus
 270   :type '(list (set :inline t
 271                     (const (windows-1250 . (mm-codepage-setup 1250 t)))
 272                     (const (windows-1251 . (mm-codepage-setup 1251 t)))
 273                     (const (windows-1253 . (mm-codepage-setup 1253 t)))
 274                     (const (windows-1257 . (mm-codepage-setup 1257 t)))
 275                     (const (cp850 . (mm-codepage-setup 850 nil))))
 276                (repeat :inline t
 277                        :tag "Other options"
 278                        (cons (symbol :tag "charset")
 279                              (symbol :tag "form"))))
 280   :group 'mime)
 281
 282 (defvar mm-binary-coding-system
 283   (cond
 284    ((mm-coding-system-p 'binary) 'binary)
 285    ((mm-coding-system-p 'no-conversion) 'no-conversion)
 286    (t nil))
 287   "100% binary coding system.")
 288
 289 (defvar mm-text-coding-system
 290   (or (if (memq system-type '(windows-nt ms-dos ms-windows))
 291           (and (mm-coding-system-p 'raw-text-dos) 'raw-text-dos)
 292         (and (mm-coding-system-p 'raw-text) 'raw-text))
 293       mm-binary-coding-system)
 294   "Text-safe coding system (For removing ^M).")
 295
 296 (defvar mm-text-coding-system-for-write nil
 297   "Text coding system for write.")
 298
 299 (defvar mm-auto-save-coding-system
 300   (cond
 301    ((mm-coding-system-p 'utf-8-emacs)   ; Mule 7
 302     (if (memq system-type '(windows-nt ms-dos ms-windows))
 303         (if (mm-coding-system-p 'utf-8-emacs-dos)
 304             'utf-8-emacs-dos mm-binary-coding-system)
 305       'utf-8-emacs))
 306    ((mm-coding-system-p 'emacs-mule)
 307     (if (memq system-type '(windows-nt ms-dos ms-windows))
 308         (if (mm-coding-system-p 'emacs-mule-dos)
 309             'emacs-mule-dos mm-binary-coding-system)
 310       'emacs-mule))
 311    ((mm-coding-system-p 'escape-quoted) 'escape-quoted)
 312    (t mm-binary-coding-system))
 313   "Coding system of auto save file.")
 314
 315 (defvar mm-universal-coding-system mm-auto-save-coding-system
 316   "The universal coding system.")
 317
 318 ;; Fixme: some of the cars here aren't valid MIME charsets.  That
 319 ;; should only matter with XEmacs, though.
 320 (defvar mm-mime-mule-charset-alist
 321   `((us-ascii ascii)
 322     (iso-8859-1 latin-iso8859-1)
 323     (iso-8859-2 latin-iso8859-2)
 324     (iso-8859-3 latin-iso8859-3)
 325     (iso-8859-4 latin-iso8859-4)
 326     (iso-8859-5 cyrillic-iso8859-5)
 327     ;; Non-mule (X)Emacs uses the last mule-charset for 8bit characters.
 328     ;; The fake mule-charset, gnus-koi8-r, tells Gnus that the default
 329     ;; charset is koi8-r, not iso-8859-5.
 330     (koi8-r cyrillic-iso8859-5 gnus-koi8-r)
 331     (iso-8859-6 arabic-iso8859-6)
 332     (iso-8859-7 greek-iso8859-7)
 333     (iso-8859-8 hebrew-iso8859-8)
 334     (iso-8859-9 latin-iso8859-9)
 335     (iso-8859-14 latin-iso8859-14)
 336     (iso-8859-15 latin-iso8859-15)
 337     (viscii vietnamese-viscii-lower)
 338     (iso-2022-jp latin-jisx0201 japanese-jisx0208 japanese-jisx0208-1978)
 339     (euc-kr korean-ksc5601)
 340     (gb2312 chinese-gb2312)
 341     (big5 chinese-big5-1 chinese-big5-2)
 342     (tibetan tibetan)
 343     (thai-tis620 thai-tis620)
 344     (windows-1251 cyrillic-iso8859-5)
 345     (iso-2022-7bit ethiopic arabic-1-column arabic-2-column)
 346     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
 347                    latin-jisx0201 japanese-jisx0208-1978
 348                    chinese-gb2312 japanese-jisx0208
 349                    korean-ksc5601 japanese-jisx0212)
 350     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
 351                     latin-jisx0201 japanese-jisx0208-1978
 352                     chinese-gb2312 japanese-jisx0208
 353                     korean-ksc5601 japanese-jisx0212
 354                     chinese-cns11643-1 chinese-cns11643-2)
 355     (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
 356                     cyrillic-iso8859-5 greek-iso8859-7
 357                     latin-jisx0201 japanese-jisx0208-1978
 358                     chinese-gb2312 japanese-jisx0208
 359                     korean-ksc5601 japanese-jisx0212
 360                     chinese-cns11643-1 chinese-cns11643-2
 361                     chinese-cns11643-3 chinese-cns11643-4
 362                     chinese-cns11643-5 chinese-cns11643-6
 363                     chinese-cns11643-7)
 364     (iso-2022-jp-3 latin-jisx0201 japanese-jisx0208-1978 japanese-jisx0208
 365                    japanese-jisx0213-1 japanese-jisx0213-2)
 366     (shift_jis latin-jisx0201 katakana-jisx0201 japanese-jisx0208)
 367     ,(if (or (not (fboundp 'charsetp)) ;; non-Mule case
 368              (charsetp 'unicode-a)
 369              (not (mm-coding-system-p 'mule-utf-8)))
 370          '(utf-8 unicode-a unicode-b unicode-c unicode-d unicode-e)
 371        ;; If we have utf-8 we're in Mule 5+.
 372        (append '(utf-8)
 373                (delete 'ascii
 374                        (coding-system-get 'mule-utf-8 'safe-charsets)))))
 375   "Alist of MIME-charset/MULE-charsets.")
 376
 377 (defun mm-enrich-utf-8-by-mule-ucs ()
 378   "Make the `utf-8' MIME charset usable by the Mule-UCS package.
 379 This function will run when the `un-define' module is loaded under
 380 XEmacs, and fill the `utf-8' entry in `mm-mime-mule-charset-alist'
 381 with Mule charsets.  It is completely useless for Emacs."
 382   (unless (cdr (delete '(mm-enrich-utf-8-by-mule-ucs)
 383                        (assoc "un-define" after-load-alist)))
 384     (setq after-load-alist
 385           (delete '("un-define") after-load-alist)))
 386   (when (boundp 'unicode-basic-translation-charset-order-list)
 387     (condition-case nil
 388         (let ((val (delq
 389                     'ascii
 390                     (copy-sequence
 391                      (symbol-value
 392                       'unicode-basic-translation-charset-order-list))))
 393               (elem (assq 'utf-8 mm-mime-mule-charset-alist)))
 394           (if elem
 395               (setcdr elem val)
 396             (setq mm-mime-mule-charset-alist
 397                   (nconc mm-mime-mule-charset-alist
 398                          (list (cons 'utf-8 val))))))
 399       (error))))
 400
 401 ;; Correct by construction, but should be unnecessary for Emacs:
 402 (if (featurep 'xemacs)
 403     (eval-after-load "un-define" '(mm-enrich-utf-8-by-mule-ucs))
 404   (when (and (fboundp 'coding-system-list)
 405              (fboundp 'sort-coding-systems))
 406     (let ((css (sort-coding-systems (coding-system-list 'base-only)))
 407           cs mime mule alist)
 408       (while css
 409         (setq cs (pop css)
 410               mime (or (coding-system-get cs :mime-charset) ; Emacs 22
 411                        (coding-system-get cs 'mime-charset)))
 412         (when (and mime
 413                    (not (eq t (setq mule
 414                                     (coding-system-get cs 'safe-charsets))))
 415                    (not (assq mime alist)))
 416           (push (cons mime (delq 'ascii mule)) alist)))
 417       (setq mm-mime-mule-charset-alist (nreverse alist)))))
 418
 419 (defvar mm-hack-charsets '(iso-8859-15 iso-2022-jp-2)
 420   "A list of special charsets.
 421 Valid elements include:
 422 `iso-8859-15'    convert ISO-8859-1, -9 to ISO-8859-15 if ISO-8859-15 exists.
 423 `iso-2022-jp-2'  convert ISO-2022-jp to ISO-2022-jp-2 if ISO-2022-jp-2 exists."
 424 )
 425
 426 (defvar mm-iso-8859-15-compatible
 427   '((iso-8859-1 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE")
 428     (iso-8859-9 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE\xD0\xDD\xDE\xF0\xFD\xFE"))
 429   "ISO-8859-15 exchangeable coding systems and inconvertible characters.")
 430
 431 (defvar mm-iso-8859-x-to-15-table
 432   (and (fboundp 'coding-system-p)
 433        (mm-coding-system-p 'iso-8859-15)
 434        (mapcar
 435         (lambda (cs)
 436           (if (mm-coding-system-p (car cs))
 437               (let ((c (string-to-char
 438                         (decode-coding-string "\341" (car cs)))))
 439                 (cons (char-charset c)
 440                       (cons
 441                        (- (string-to-char
 442                            (decode-coding-string "\341" 'iso-8859-15)) c)
 443                        (string-to-list (decode-coding-string (car (cdr cs))
 444                                                              (car cs))))))
 445             '(gnus-charset 0)))
 446         mm-iso-8859-15-compatible))
 447   "A table of the difference character between ISO-8859-X and ISO-8859-15.")
 448
 449 (defcustom mm-coding-system-priorities
 450   (if (boundp 'current-language-environment)
 451       (let ((lang (symbol-value 'current-language-environment)))
 452         (cond ((string= lang "Japanese")
 453                ;; Japanese users prefer iso-2022-jp to euc-japan or
 454                ;; shift_jis, however iso-8859-1 should be used when
 455                ;; there are only ASCII text and Latin-1 characters.
 456                '(iso-8859-1 iso-2022-jp iso-2022-jp-2 shift_jis utf-8)))))
 457   "Preferred coding systems for encoding outgoing messages.
 458
 459 More than one suitable coding system may be found for some text.
 460 By default, the coding system with the highest priority is used
 461 to encode outgoing messages (see `sort-coding-systems').  If this
 462 variable is set, it overrides the default priority."
 463   :version "21.2"
 464   :type '(repeat (symbol :tag "Coding system"))
 465   :group 'mime)
 466
 467 ;; ??
 468 (defvar mm-use-find-coding-systems-region
 469   (fboundp 'find-coding-systems-region)
 470   "Use `find-coding-systems-region' to find proper coding systems.
 471
 472 Setting it to nil is useful on Emacsen supporting Unicode if sending
 473 mail with multiple parts is preferred to sending a Unicode one.")
 474
 475 ;;; Internal variables:
 476
 477 ;;; Functions:
 478
 479 (defun mm-mule-charset-to-mime-charset (charset)
 480   "Return the MIME charset corresponding to the given Mule CHARSET."
 481   (if (and (fboundp 'find-coding-systems-for-charsets)
 482            (fboundp 'sort-coding-systems))
 483       (let ((css (sort (sort-coding-systems
 484                         (find-coding-systems-for-charsets (list charset)))
 485                        'mm-sort-coding-systems-predicate))
 486             cs mime)
 487         (while (and (not mime)
 488                     css)
 489           (when (setq cs (pop css))
 490             (setq mime (or (coding-system-get cs :mime-charset)
 491                            (coding-system-get cs 'mime-charset)))))
 492         mime)
 493     (let ((alist (mapcar (lambda (cs)
 494                            (assq cs mm-mime-mule-charset-alist))
 495                          (sort (mapcar 'car mm-mime-mule-charset-alist)
 496                                'mm-sort-coding-systems-predicate)))
 497           out)
 498       (while alist
 499         (when (memq charset (cdar alist))
 500           (setq out (caar alist)
 501                 alist nil))
 502         (pop alist))
 503       out)))
 504
 505 (defun mm-charset-to-coding-system (charset &optional lbt
 506                                             allow-override)
 507   "Return coding-system corresponding to CHARSET.
 508 CHARSET is a symbol naming a MIME charset.
 509 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
 510 used as the line break code type of the coding system.
 511
 512 If ALLOW-OVERRIDE is given, use `mm-charset-override-alist' to
 513 map undesired charset names to their replacement.  This should
 514 only be used for decoding, not for encoding."
 515   ;; OVERRIDE is used (only) in `mm-decode-body'.
 516   (when (stringp charset)
 517     (setq charset (intern (downcase charset))))
 518   (when lbt
 519     (setq charset (intern (format "%s-%s" charset lbt))))
 520   (cond
 521    ((null charset)
 522     charset)
 523    ;; Running in a non-MULE environment.
 524    ((or (null (mm-get-coding-system-list))
 525         (not (fboundp 'coding-system-get)))
 526     charset)
 527    ;; Check override list quite early.  Should only used for decoding, not for
 528    ;; encoding!
 529    ((and allow-override
 530          (let ((cs (cdr (assq charset mm-charset-override-alist))))
 531            (and cs (mm-coding-system-p cs) cs))))
 532    ;; ascii
 533    ((eq charset 'us-ascii)
 534     'ascii)
 535    ;; Check to see whether we can handle this charset.  (This depends
 536    ;; on there being some coding system matching each `mime-charset'
 537    ;; property defined, as there should be.)
 538    ((and (mm-coding-system-p charset)
 539 ;;; Doing this would potentially weed out incorrect charsets.
 540 ;;;      charset
 541 ;;;      (eq charset (coding-system-get charset 'mime-charset))
 542          )
 543     charset)
 544    ;; Eval expressions from `mm-charset-eval-alist'
 545    ((let* ((el (assq charset mm-charset-eval-alist))
 546            (cs (car el))
 547            (form (cdr el)))
 548       (and cs
 549            form
 550            (prog2
 551                ;; Avoid errors...
 552                (condition-case nil (eval form) (error nil))
 553                ;; (message "Failed to eval `%s'" form))
 554                (mm-coding-system-p cs)
 555              (message "Added charset `%s' via `mm-charset-eval-alist'" cs))
 556            cs)))
 557    ;; Translate invalid charsets.
 558    ((let ((cs (cdr (assq charset mm-charset-synonym-alist))))
 559       (and cs
 560            (mm-coding-system-p cs)
 561            ;; (message
 562            ;;  "Using synonym `%s' from `mm-charset-synonym-alist' for `%s'"
 563            ;;  cs charset)
 564            cs)))
 565    ;; Last resort: search the coding system list for entries which
 566    ;; have the right mime-charset in case the canonical name isn't
 567    ;; defined (though it should be).
 568    ((let (cs)
 569       ;; mm-get-coding-system-list returns a list of cs without lbt.
 570       ;; Do we need -lbt?
 571       (dolist (c (mm-get-coding-system-list))
 572         (if (and (null cs)
 573                  (eq charset (or (coding-system-get c :mime-charset)
 574                                  (coding-system-get c 'mime-charset))))
 575             (setq cs c)))
 576       (unless cs
 577         ;; Warn the user about unknown charset:
 578         (if (fboundp 'gnus-message)
 579             (gnus-message 7 "Unknown charset: %s" charset)
 580           (message "Unknown charset: %s" charset)))
 581       cs))))
 582
 583 (eval-and-compile
 584   (defvar mm-emacs-mule (and (not (featurep 'xemacs))
 585                              (boundp 'default-enable-multibyte-characters)
 586                              default-enable-multibyte-characters
 587                              (fboundp 'set-buffer-multibyte))
 588     "True in Emacs with Mule.")
 589
 590   (if mm-emacs-mule
 591       (defun mm-enable-multibyte ()
 592         "Set the multibyte flag of the current buffer.
 593 Only do this if the default value of `enable-multibyte-characters' is
 594 non-nil.  This is a no-op in XEmacs."
 595         (set-buffer-multibyte 'to))
 596     (defalias 'mm-enable-multibyte 'ignore))
 597
 598   (if mm-emacs-mule
 599       (defun mm-disable-multibyte ()
 600         "Unset the multibyte flag of in the current buffer.
 601 This is a no-op in XEmacs."
 602         (set-buffer-multibyte nil))
 603     (defalias 'mm-disable-multibyte 'ignore)))
 604
 605 (defun mm-preferred-coding-system (charset)
 606   ;; A typo in some Emacs versions.
 607   (or (get-charset-property charset 'preferred-coding-system)
 608       (get-charset-property charset 'prefered-coding-system)))
 609
 610 ;; Mule charsets shouldn't be used.
 611 (defsubst mm-guess-charset ()
 612   "Guess Mule charset from the language environment."
 613   (or
 614    mail-parse-mule-charset ;; cached mule-charset
 615    (progn
 616      (setq mail-parse-mule-charset
 617            (and (boundp 'current-language-environment)
 618                 (car (last
 619                       (assq 'charset
 620                             (assoc current-language-environment
 621                                    language-info-alist))))))
 622      (if (or (not mail-parse-mule-charset)
 623              (eq mail-parse-mule-charset 'ascii))
 624          (setq mail-parse-mule-charset
 625                (or (car (last (assq mail-parse-charset
 626                                     mm-mime-mule-charset-alist)))
 627                    ;; default
 628                    'latin-iso8859-1)))
 629      mail-parse-mule-charset)))
 630
 631 (defun mm-charset-after (&optional pos)
 632   "Return charset of a character in current buffer at position POS.
 633 If POS is nil, it defauls to the current point.
 634 If POS is out of range, the value is nil.
 635 If the charset is `composition', return the actual one."
 636   (let ((char (char-after pos)) charset)
 637     (if (< (mm-char-int char) 128)
 638         (setq charset 'ascii)
 639       ;; charset-after is fake in some Emacsen.
 640       (setq charset (and (fboundp 'char-charset) (char-charset char)))
 641       (if (eq charset 'composition)     ; Mule 4
 642           (let ((p (or pos (point))))
 643             (cadr (find-charset-region p (1+ p))))
 644         (if (and charset (not (memq charset '(ascii eight-bit-control
 645                                                     eight-bit-graphic))))
 646             charset
 647           (mm-guess-charset))))))
 648
 649 (defun mm-mime-charset (charset)
 650   "Return the MIME charset corresponding to the given Mule CHARSET."
 651   (if (eq charset 'unknown)
 652       (error "The message contains non-printable characters, please use attachment"))
 653   (if (and (fboundp 'coding-system-get) (fboundp 'get-charset-property))
 654       ;; This exists in Emacs 20.
 655       (or
 656        (and (mm-preferred-coding-system charset)
 657             (or (coding-system-get
 658                  (mm-preferred-coding-system charset) :mime-charset)
 659                 (coding-system-get
 660                  (mm-preferred-coding-system charset) 'mime-charset)))
 661        (and (eq charset 'ascii)
 662             'us-ascii)
 663        (mm-preferred-coding-system charset)
 664        (mm-mule-charset-to-mime-charset charset))
 665     ;; This is for XEmacs.
 666     (mm-mule-charset-to-mime-charset charset)))
 667
 668 (if (fboundp 'delete-dups)
 669     (defalias 'mm-delete-duplicates 'delete-dups)
 670   (defun mm-delete-duplicates (list)
 671     "Destructively remove `equal' duplicates from LIST.
 672 Store the result in LIST and return it.  LIST must be a proper list.
 673 Of several `equal' occurrences of an element in LIST, the first
 674 one is kept.
 675
 676 This is a compatibility function for Emacsen without `delete-dups'."
 677     ;; Code from `subr.el' in Emacs 22:
 678     (let ((tail list))
 679       (while tail
 680         (setcdr tail (delete (car tail) (cdr tail)))
 681         (setq tail (cdr tail))))
 682     list))
 683
 684 ;; Fixme:  This is used in places when it should be testing the
 685 ;; default multibyteness.  See mm-default-multibyte-p.
 686 (eval-and-compile
 687   (if (and (not (featurep 'xemacs))
 688            (boundp 'enable-multibyte-characters))
 689       (defun mm-multibyte-p ()
 690         "Non-nil if multibyte is enabled in the current buffer."
 691         enable-multibyte-characters)
 692     (defun mm-multibyte-p () (featurep 'mule))))
 693
 694 (defun mm-default-multibyte-p ()
 695   "Return non-nil if the session is multibyte.
 696 This affects whether coding conversion should be attempted generally."
 697   (if (featurep 'mule)
 698       (if (boundp 'default-enable-multibyte-characters)
 699           default-enable-multibyte-characters
 700         t)))
 701
 702 (defun mm-iso-8859-x-to-15-region (&optional b e)
 703   (if (fboundp 'char-charset)
 704       (let (charset item c inconvertible)
 705         (save-restriction
 706           (if e (narrow-to-region b e))
 707           (goto-char (point-min))
 708           (skip-chars-forward "\0-\177")
 709           (while (not (eobp))
 710             (cond
 711              ((not (setq item (assq (char-charset (setq c (char-after)))
 712                                     mm-iso-8859-x-to-15-table)))
 713               (forward-char))
 714              ((memq c (cdr (cdr item)))
 715               (setq inconvertible t)
 716               (forward-char))
 717              (t
 718               (insert-before-markers (prog1 (+ c (car (cdr item)))
 719                                        (delete-char 1)))))
 720             (skip-chars-forward "\0-\177")))
 721         (not inconvertible))))
 722
 723 (defun mm-sort-coding-systems-predicate (a b)
 724   (let ((priorities
 725          (mapcar (lambda (cs)
 726                    ;; Note: invalid entries are dropped silently
 727                    (and (setq cs (mm-coding-system-p cs))
 728                         (coding-system-base cs)))
 729                  mm-coding-system-priorities)))
 730     (and (setq a (mm-coding-system-p a))
 731          (if (setq b (mm-coding-system-p b))
 732              (> (length (memq (coding-system-base a) priorities))
 733                 (length (memq (coding-system-base b) priorities)))
 734            t))))
 735
 736 (eval-when-compile
 737   (autoload 'latin-unity-massage-name "latin-unity")
 738   (autoload 'latin-unity-maybe-remap "latin-unity")
 739   (autoload 'latin-unity-representations-feasible-region "latin-unity")
 740   (autoload 'latin-unity-representations-present-region "latin-unity")
 741   (defvar latin-unity-coding-systems)
 742   (defvar latin-unity-ucs-list))
 743
 744 (defun mm-xemacs-find-mime-charset-1 (begin end)
 745   "Determine which MIME charset to use to send region as message.
 746 This uses the XEmacs-specific latin-unity package to better handle the
 747 case where identical characters from diverse ISO-8859-? character sets
 748 can be encoded using a single one of the corresponding coding systems.
 749
 750 It treats `mm-coding-system-priorities' as the list of preferred
 751 coding systems; a useful example setting for this list in Western
 752 Europe would be '(iso-8859-1 iso-8859-15 utf-8), which would default
 753 to the very standard Latin 1 coding system, and only move to coding
 754 systems that are less supported as is necessary to encode the
 755 characters that exist in the buffer.
 756
 757 Latin Unity doesn't know about those non-ASCII Roman characters that
 758 are available in various East Asian character sets.  As such, its
 759 behavior if you have a JIS 0212 LATIN SMALL LETTER A WITH ACUTE in a
 760 buffer and it can otherwise be encoded as Latin 1, won't be ideal.
 761 But this is very much a corner case, so don't worry about it."
 762   (let ((systems mm-coding-system-priorities) csets psets curset)
 763
 764     ;; Load the Latin Unity library, if available.
 765     (when (and (not (featurep 'latin-unity)) (locate-library "latin-unity"))
 766       (require 'latin-unity))
 767
 768     ;; Now, can we use it?
 769     (if (featurep 'latin-unity)
 770         (progn
 771           (setq csets (latin-unity-representations-feasible-region begin end)
 772                 psets (latin-unity-representations-present-region begin end))
 773
 774           (catch 'done
 775
 776             ;; Pass back the first coding system in the preferred list
 777             ;; that can encode the whole region.
 778             (dolist (curset systems)
 779               (setq curset (latin-unity-massage-name 'buffer-default curset))
 780
 781               ;; If the coding system is a universal coding system, then
 782               ;; it can certainly encode all the characters in the region.
 783               (if (memq curset latin-unity-ucs-list)
 784                   (throw 'done (list curset)))
 785
 786               ;; If a coding system isn't universal, and isn't in
 787               ;; the list that latin unity knows about, we can't
 788               ;; decide whether to use it here. Leave that until later
 789               ;; in `mm-find-mime-charset-region' function, whence we
 790               ;; have been called.
 791               (unless (memq curset latin-unity-coding-systems)
 792                 (throw 'done nil))
 793
 794               ;; Right, we know about this coding system, and it may
 795               ;; conceivably be able to encode all the characters in
 796               ;; the region.
 797               (if (latin-unity-maybe-remap begin end curset csets psets t)
 798                   (throw 'done (list curset))))
 799
 800             ;; Can't encode using anything from the
 801             ;; `mm-coding-system-priorities' list.
 802             ;; Leave `mm-find-mime-charset' to do most of the work.
 803             nil))
 804
 805       ;; Right, latin unity isn't available; let `mm-find-charset-region'
 806       ;; take its default action, which equally applies to GNU Emacs.
 807       nil)))
 808
 809 (defmacro mm-xemacs-find-mime-charset (begin end)
 810   (when (featurep 'xemacs)
 811     `(and (featurep 'mule) (mm-xemacs-find-mime-charset-1 ,begin ,end))))
 812
 813 (defun mm-find-mime-charset-region (b e &optional hack-charsets)
 814   "Return the MIME charsets needed to encode the region between B and E.
 815 nil means ASCII, a single-element list represents an appropriate MIME
 816 charset, and a longer list means no appropriate charset."
 817   (let (charsets)
 818     ;; The return possibilities of this function are a mess...
 819     (or (and (mm-multibyte-p)
 820              mm-use-find-coding-systems-region
 821              ;; Find the mime-charset of the most preferred coding
 822              ;; system that has one.
 823              (let ((systems (find-coding-systems-region b e)))
 824                (when mm-coding-system-priorities
 825                  (setq systems
 826                        (sort systems 'mm-sort-coding-systems-predicate)))
 827                (setq systems (delq 'compound-text systems))
 828                (unless (equal systems '(undecided))
 829                  (while systems
 830                    (let* ((head (pop systems))
 831                           (cs (or (coding-system-get head :mime-charset)
 832                                   (coding-system-get head 'mime-charset))))
 833                      ;; The mime-charset (`x-ctext') of
 834                      ;; `compound-text' is not in the IANA list.  We
 835                      ;; shouldn't normally use anything here with a
 836                      ;; mime-charset having an `x-' prefix.
 837                      ;; Fixme:  Allow this to be overridden, since
 838                      ;; there is existing use of x-ctext.
 839                      ;; Also people apparently need the coding system
 840                      ;; `iso-2022-jp-3' (which Mule-UCS defines with
 841                      ;; mime-charset, though it's not valid).
 842                      (if (and cs
 843                               (not (string-match "^[Xx]-" (symbol-name cs)))
 844                               ;; UTF-16 of any variety is invalid for
 845                               ;; text parts and, unfortunately, has
 846                               ;; mime-charset defined both in Mule-UCS
 847                               ;; and versions of Emacs.  (The name
 848                               ;; might be `mule-utf-16...'  or
 849                               ;; `utf-16...'.)
 850                               (not (string-match "utf-16" (symbol-name cs))))
 851                          (setq systems nil
 852                                charsets (list cs))))))
 853                charsets))
 854         ;; If we're XEmacs, and some coding system is appropriate,
 855         ;; mm-xemacs-find-mime-charset will return an appropriate list.
 856         ;; Otherwise, we'll get nil, and the next setq will get invoked.
 857         (setq charsets (mm-xemacs-find-mime-charset b e))
 858
 859         ;; We're not multibyte, or a single coding system won't cover it.
 860         (setq charsets
 861               (mm-delete-duplicates
 862                (mapcar 'mm-mime-charset
 863                        (delq 'ascii
 864                              (mm-find-charset-region b e))))))
 865     (if (and (> (length charsets) 1)
 866              (memq 'iso-8859-15 charsets)
 867              (memq 'iso-8859-15 hack-charsets)
 868              (save-excursion (mm-iso-8859-x-to-15-region b e)))
 869         (mapcar (lambda (x) (setq charsets (delq (car x) charsets)))
 870                 mm-iso-8859-15-compatible))
 871     (if (and (memq 'iso-2022-jp-2 charsets)
 872              (memq 'iso-2022-jp-2 hack-charsets))
 873         (setq charsets (delq 'iso-2022-jp charsets)))
 874     ;; Attempt to reduce the number of charsets if utf-8 is available.
 875     (if (and (featurep 'xemacs)
 876              (> (length charsets) 1)
 877              (mm-coding-system-p 'utf-8))
 878         (let ((mm-coding-system-priorities
 879                (cons 'utf-8 mm-coding-system-priorities)))
 880           (setq charsets
 881                 (mm-delete-duplicates
 882                  (mapcar 'mm-mime-charset
 883                          (delq 'ascii
 884                                (mm-find-charset-region b e)))))))
 885     charsets))
 886
 887 (defmacro mm-with-unibyte-buffer (&rest forms)
 888   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 889 Use unibyte mode for this."
 890   `(let (default-enable-multibyte-characters)
 891      (with-temp-buffer ,@forms)))
 892 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
 893 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
 894
 895 (defmacro mm-with-multibyte-buffer (&rest forms)
 896   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 897 Use multibyte mode for this."
 898   `(let ((default-enable-multibyte-characters t))
 899      (with-temp-buffer ,@forms)))
 900 (put 'mm-with-multibyte-buffer 'lisp-indent-function 0)
 901 (put 'mm-with-multibyte-buffer 'edebug-form-spec '(body))
 902
 903 (defmacro mm-with-unibyte-current-buffer (&rest forms)
 904   "Evaluate FORMS with current buffer temporarily made unibyte.
 905 Also bind `default-enable-multibyte-characters' to nil.
 906 Equivalent to `progn' in XEmacs"
 907   (let ((multibyte (make-symbol "multibyte"))
 908         (buffer (make-symbol "buffer")))
 909     `(if mm-emacs-mule
 910          (let ((,multibyte enable-multibyte-characters)
 911                (,buffer (current-buffer)))
 912            (unwind-protect
 913                (let (default-enable-multibyte-characters)
 914                  (set-buffer-multibyte nil)
 915                  ,@forms)
 916              (set-buffer ,buffer)
 917              (set-buffer-multibyte ,multibyte)))
 918        (let (default-enable-multibyte-characters)
 919          ,@forms))))
 920 (put 'mm-with-unibyte-current-buffer 'lisp-indent-function 0)
 921 (put 'mm-with-unibyte-current-buffer 'edebug-form-spec '(body))
 922
 923 (defmacro mm-with-unibyte (&rest forms)
 924   "Eval the FORMS with the default value of `enable-multibyte-characters' nil."
 925   `(let (default-enable-multibyte-characters)
 926      ,@forms))
 927 (put 'mm-with-unibyte 'lisp-indent-function 0)
 928 (put 'mm-with-unibyte 'edebug-form-spec '(body))
 929
 930 (defmacro mm-with-multibyte (&rest forms)
 931   "Eval the FORMS with the default value of `enable-multibyte-characters' t."
 932   `(let ((default-enable-multibyte-characters t))
 933      ,@forms))
 934 (put 'mm-with-multibyte 'lisp-indent-function 0)
 935 (put 'mm-with-multibyte 'edebug-form-spec '(body))
 936
 937 (defun mm-find-charset-region (b e)
 938   "Return a list of Emacs charsets in the region B to E."
 939   (cond
 940    ((and (mm-multibyte-p)
 941          (fboundp 'find-charset-region))
 942     ;; Remove composition since the base charsets have been included.
 943     ;; Remove eight-bit-*, treat them as ascii.
 944     (let ((css (find-charset-region b e)))
 945       (mapcar (lambda (cs) (setq css (delq cs css)))
 946               '(composition eight-bit-control eight-bit-graphic
 947                             control-1))
 948       css))
 949    (t
 950     ;; We are in a unibyte buffer or XEmacs non-mule, so we futz around a bit.
 951     (save-excursion
 952       (save-restriction
 953         (narrow-to-region b e)
 954         (goto-char (point-min))
 955         (skip-chars-forward "\0-\177")
 956         (if (eobp)
 957             '(ascii)
 958           (let (charset)
 959             (setq charset
 960                   (and (boundp 'current-language-environment)
 961                        (car (last (assq 'charset
 962                                         (assoc current-language-environment
 963                                                language-info-alist))))))
 964             (if (eq charset 'ascii) (setq charset nil))
 965             (or charset
 966                 (setq charset
 967                       (car (last (assq mail-parse-charset
 968                                        mm-mime-mule-charset-alist)))))
 969             (list 'ascii (or charset 'latin-iso8859-1)))))))))
 970
 971 (defun mm-auto-mode-alist ()
 972   "Return an `auto-mode-alist' with only the .gz (etc) thingies."
 973   (let ((alist auto-mode-alist)
 974         out)
 975     (while alist
 976       (when (listp (cdar alist))
 977         (push (car alist) out))
 978       (pop alist))
 979     (nreverse out)))
 980
 981 (defvar mm-inhibit-file-name-handlers
 982   '(jka-compr-handler image-file-handler)
 983   "A list of handlers doing (un)compression (etc) thingies.")
 984
 985 (defun mm-insert-file-contents (filename &optional visit beg end replace
 986                                          inhibit)
 987   "Like `insert-file-contents', but only reads in the file.
 988 A buffer may be modified in several ways after reading into the buffer due
 989 to advanced Emacs features, such as file-name-handlers, format decoding,
 990 `find-file-hooks', etc.
 991 If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'.
 992   This function ensures that none of these modifications will take place."
 993   (let* ((format-alist nil)
 994          (auto-mode-alist (if inhibit nil (mm-auto-mode-alist)))
 995          (default-major-mode 'fundamental-mode)
 996          (enable-local-variables nil)
 997          (after-insert-file-functions nil)
 998          (enable-local-eval nil)
 999          (inhibit-file-name-operation (if inhibit
1000                                           'insert-file-contents
1001                                         inhibit-file-name-operation))
1002          (inhibit-file-name-handlers
1003           (if inhibit
1004               (append mm-inhibit-file-name-handlers
1005                       inhibit-file-name-handlers)
1006             inhibit-file-name-handlers))
1007          (ffh (if (boundp 'find-file-hook)
1008                   'find-file-hook
1009                 'find-file-hooks))
1010          (val (symbol-value ffh)))
1011     (set ffh nil)
1012     (unwind-protect
1013         (insert-file-contents filename visit beg end replace)
1014       (set ffh val))))
1015
1016 (defun mm-append-to-file (start end filename &optional codesys inhibit)
1017   "Append the contents of the region to the end of file FILENAME.
1018 When called from a function, expects three arguments,
1019 START, END and FILENAME.  START and END are buffer positions
1020 saying what text to write.
1021 Optional fourth argument specifies the coding system to use when
1022 encoding the file.
1023 If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'."
1024   (let ((coding-system-for-write
1025          (or codesys mm-text-coding-system-for-write
1026              mm-text-coding-system))
1027         (inhibit-file-name-operation (if inhibit
1028                                          'append-to-file
1029                                        inhibit-file-name-operation))
1030         (inhibit-file-name-handlers
1031          (if inhibit
1032              (append mm-inhibit-file-name-handlers
1033                      inhibit-file-name-handlers)
1034            inhibit-file-name-handlers)))
1035     (write-region start end filename t 'no-message)
1036     (message "Appended to %s" filename)))
1037
1038 (defun mm-write-region (start end filename &optional append visit lockname
1039                               coding-system inhibit)
1040
1041   "Like `write-region'.
1042 If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'."
1043   (let ((coding-system-for-write
1044          (or coding-system mm-text-coding-system-for-write
1045              mm-text-coding-system))
1046         (inhibit-file-name-operation (if inhibit
1047                                          'write-region
1048                                        inhibit-file-name-operation))
1049         (inhibit-file-name-handlers
1050          (if inhibit
1051              (append mm-inhibit-file-name-handlers
1052                      inhibit-file-name-handlers)
1053            inhibit-file-name-handlers)))
1054     (write-region start end filename append visit lockname)))
1055
1056 (defun mm-image-load-path (&optional package)
1057   (let (dir result)
1058     (dolist (path load-path (nreverse result))
1059       (when (and path
1060                  (file-directory-p
1061                   (setq dir (concat (file-name-directory
1062                                      (directory-file-name path))
1063                                     "etc/images/" (or package "gnus/")))))
1064         (push dir result))
1065       (push path result))))
1066
1067 ;; Fixme: This doesn't look useful where it's used.
1068 (if (fboundp 'detect-coding-region)
1069     (defun mm-detect-coding-region (start end)
1070       "Like `detect-coding-region' except returning the best one."
1071       (let ((coding-systems
1072              (detect-coding-region start end)))
1073         (or (car-safe coding-systems)
1074             coding-systems)))
1075   (defun mm-detect-coding-region (start end)
1076     (let ((point (point)))
1077       (goto-char start)
1078       (skip-chars-forward "\0-\177" end)
1079       (prog1
1080           (if (eq (point) end) 'ascii (mm-guess-charset))
1081         (goto-char point)))))
1082
1083 (if (fboundp 'coding-system-get)
1084     (defun mm-detect-mime-charset-region (start end)
1085       "Detect MIME charset of the text in the region between START and END."
1086       (let ((cs (mm-detect-coding-region start end)))
1087         (or (coding-system-get cs :mime-charset)
1088             (coding-system-get cs 'mime-charset))))
1089   (defun mm-detect-mime-charset-region (start end)
1090     "Detect MIME charset of the text in the region between START and END."
1091     (let ((cs (mm-detect-coding-region start end)))
1092       cs)))
1093
1094 (eval-when-compile
1095   (unless (fboundp 'coding-system-to-mime-charset)
1096     (defalias 'coding-system-to-mime-charset 'ignore)))
1097
1098 (defun mm-coding-system-to-mime-charset (coding-system)
1099   "Return the MIME charset corresponding to CODING-SYSTEM.
1100 To make this function work with XEmacs, the APEL package is required."
1101   (when coding-system
1102     (or (and (fboundp 'coding-system-get)
1103              (or (coding-system-get coding-system :mime-charset)
1104                  (coding-system-get coding-system 'mime-charset)))
1105         (and (featurep 'xemacs)
1106              (or (and (fboundp 'coding-system-to-mime-charset)
1107                       (not (eq (symbol-function 'coding-system-to-mime-charset)
1108                                'ignore)))
1109                  (and (condition-case nil
1110                           (require 'mcharset)
1111                         (error nil))
1112                       (fboundp 'coding-system-to-mime-charset)))
1113              (coding-system-to-mime-charset coding-system)))))
1114
1115 (eval-when-compile
1116   (require 'jka-compr))
1117
1118 (defun mm-decompress-buffer (filename &optional inplace force)
1119   "Decompress buffer's contents, depending on jka-compr.
1120 Only when FORCE is t or `auto-compression-mode' is enabled and FILENAME
1121 agrees with `jka-compr-compression-info-list', decompression is done.
1122 Signal an error if FORCE is neither nil nor t and compressed data are
1123 not decompressed because `auto-compression-mode' is disabled.
1124 If INPLACE is nil, return decompressed data or nil without modifying
1125 the buffer.  Otherwise, replace the buffer's contents with the
1126 decompressed data.  The buffer's multibyteness must be turned off."
1127   (when (and filename
1128              (if force
1129                  (prog1 t (require 'jka-compr))
1130                (and (fboundp 'jka-compr-installed-p)
1131                     (jka-compr-installed-p))))
1132     (let ((info (jka-compr-get-compression-info filename)))
1133       (when info
1134         (unless (or (memq force (list nil t))
1135                     (jka-compr-installed-p))
1136           (error ""))
1137         (let ((prog (jka-compr-info-uncompress-program info))
1138               (args (jka-compr-info-uncompress-args info))
1139               (msg (format "%s %s..."
1140                            (jka-compr-info-uncompress-message info)
1141                            filename))
1142               (err-file (jka-compr-make-temp-name))
1143               (cur (current-buffer))
1144               (coding-system-for-read mm-binary-coding-system)
1145               (coding-system-for-write mm-binary-coding-system)
1146               retval err-msg)
1147           (message "%s" msg)
1148           (with-temp-buffer
1149             (insert-buffer-substring cur)
1150             (condition-case err
1151                 (progn
1152                   (unless (memq (apply 'call-process-region
1153                                        (point-min) (point-max)
1154                                        prog t (list t err-file) nil args)
1155                                 jka-compr-acceptable-retval-list)
1156                     (erase-buffer)
1157                     (insert (mapconcat
1158                              'identity
1159                              (delete "" (split-string
1160                                          (prog2
1161                                              (insert-file-contents err-file)
1162                                              (buffer-string)
1163                                            (erase-buffer))))
1164                              " ")
1165                             "\n")
1166                     (setq err-msg
1167                           (format "Error while executing \"%s %s < %s\""
1168                                   prog (mapconcat 'identity args " ")
1169                                   filename)))
1170                   (setq retval (buffer-string)))
1171               (error
1172                (setq err-msg (error-message-string err)))))
1173           (when (file-exists-p err-file)
1174             (ignore-errors (jka-compr-delete-temp-file err-file)))
1175           (when inplace
1176             (unless err-msg
1177               (delete-region (point-min) (point-max))
1178               (insert retval))
1179             (setq retval nil))
1180           (message "%s" (or err-msg (concat msg "done")))
1181           retval)))))
1182
1183 (eval-when-compile
1184   (unless (fboundp 'coding-system-name)
1185     (defalias 'coding-system-name 'ignore))
1186   (unless (fboundp 'find-file-coding-system-for-read-from-filename)
1187     (defalias 'find-file-coding-system-for-read-from-filename 'ignore))
1188   (unless (fboundp 'find-operation-coding-system)
1189     (defalias 'find-operation-coding-system 'ignore)))
1190
1191 (defun mm-find-buffer-file-coding-system (&optional filename)
1192   "Find coding system used to decode the contents of the current buffer.
1193 This function looks for the coding system magic cookie or examines the
1194 coding system specified by `file-coding-system-alist' being associated
1195 with FILENAME which defaults to `buffer-file-name'.  Data compressed by
1196 gzip, bzip2, etc. are allowed."
1197   (unless filename
1198     (setq filename buffer-file-name))
1199   (save-excursion
1200     (let ((decomp (unless ;; No worth to examine charset of tar files.
1201                       (and filename
1202                            (string-match
1203                             "\\.\\(?:tar\\.[^.]+\\|tbz\\|tgz\\)\\'"
1204                             filename))
1205                     (mm-decompress-buffer filename nil t))))
1206       (when decomp
1207         (set-buffer (let (default-enable-multibyte-characters)
1208                       (generate-new-buffer " *temp*")))
1209         (insert decomp)
1210         (setq filename (file-name-sans-extension filename)))
1211       (goto-char (point-min))
1212       (prog1
1213           (cond
1214            ((boundp 'set-auto-coding-function) ;; Emacs
1215             (if filename
1216                 (or (funcall (symbol-value 'set-auto-coding-function)
1217                              filename (- (point-max) (point-min)))
1218                     (car (find-operation-coding-system 'insert-file-contents
1219                                                        filename)))
1220               (let (auto-coding-alist)
1221                 (condition-case nil
1222                     (funcall (symbol-value 'set-auto-coding-function)
1223                              nil (- (point-max) (point-min)))
1224                   (error nil)))))
1225            ((featurep 'file-coding) ;; XEmacs
1226             (let ((case-fold-search t)
1227                   (end (point-at-eol))
1228                   codesys start)
1229               (or
1230                (and (re-search-forward "-\\*-+[\t ]*" end t)
1231                     (progn
1232                       (setq start (match-end 0))
1233                       (re-search-forward "[\t ]*-+\\*-" end t))
1234                     (progn
1235                       (setq end (match-beginning 0))
1236                       (goto-char start)
1237                       (or (looking-at "coding:[\t ]*\\([^\t ;]+\\)")
1238                           (re-search-forward
1239                            "[\t ;]+coding:[\t ]*\\([^\t ;]+\\)"
1240                            end t)))
1241                     (find-coding-system (setq codesys
1242                                               (intern (match-string 1))))
1243                     codesys)
1244                (and (re-search-forward "^[\t ]*;+[\t ]*Local[\t ]+Variables:"
1245                                        nil t)
1246                     (progn
1247                       (setq start (match-end 0))
1248                       (re-search-forward "^[\t ]*;+[\t ]*End:" nil t))
1249                     (progn
1250                       (setq end (match-beginning 0))
1251                       (goto-char start)
1252                       (re-search-forward
1253                        "^[\t ]*;+[\t ]*coding:[\t ]*\\([^\t\n\r ]+\\)"
1254                        end t))
1255                     (find-coding-system (setq codesys
1256                                               (intern (match-string 1))))
1257                     codesys)
1258                (and (progn
1259                       (goto-char (point-min))
1260                       (setq case-fold-search nil)
1261                       (re-search-forward "^;;;coding system: "
1262                                          ;;(+ (point-min) 3000) t))
1263                                          nil t))
1264                     (looking-at "[^\t\n\r ]+")
1265                     (find-coding-system
1266                      (setq codesys (intern (match-string 0))))
1267                     codesys)
1268                (and filename
1269                     (setq codesys
1270                           (find-file-coding-system-for-read-from-filename
1271                            filename))
1272                     (coding-system-name (coding-system-base codesys)))))))
1273         (when decomp
1274           (kill-buffer (current-buffer)))))))
1275
1276 (provide 'mm-util)
1277
1278 ;; arch-tag: 94dc5388-825d-4fd1-bfa5-2100aa351238
1279 ;;; mm-util.el ends here