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