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, 2006 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   (if (featurep 'xemacs)
  34       (unless (ignore-errors
  35                 (require 'timer-funcs))
  36         (require 'timer))
  37     (require 'timer)))
  38
  39 (eval-and-compile
  40   (mapcar
  41    (lambda (elem)
  42      (let ((nfunc (intern (format "mm-%s" (car elem)))))
  43        (if (fboundp (car elem))
  44            (defalias nfunc (car elem))
  45          (defalias nfunc (cdr elem)))))
  46    '((decode-coding-string . (lambda (s a) s))
  47      (encode-coding-string . (lambda (s a) s))
  48      (encode-coding-region . ignore)
  49      (coding-system-list . ignore)
  50      (decode-coding-region . ignore)
  51      (char-int . identity)
  52      (coding-system-equal . equal)
  53      (annotationp . ignore)
  54      (set-buffer-file-coding-system . ignore)
  55      (read-charset
  56       . (lambda (prompt)
  57           "Return a charset."
  58           (intern
  59            (completing-read
  60             prompt
  61             (mapcar (lambda (e) (list (symbol-name (car e))))
  62                     mm-mime-mule-charset-alist)
  63             nil t))))
  64      (subst-char-in-string
  65       . (lambda (from to string &optional inplace)
  66           ;; stolen (and renamed) from nnheader.el
  67           "Replace characters in STRING from FROM to TO.
  68           Unless optional argument INPLACE is non-nil, return a new string."
  69           (let ((string (if inplace string (copy-sequence string)))
  70                 (len (length string))
  71                 (idx 0))
  72             ;; Replace all occurrences of FROM with TO.
  73             (while (< idx len)
  74               (when (= (aref string idx) from)
  75                 (aset string idx to))
  76               (setq idx (1+ idx)))
  77             string)))
  78      (replace-in-string
  79       . (lambda (string regexp rep &optional literal)
  80           "See `replace-regexp-in-string', only the order of args differs."
  81           (replace-regexp-in-string regexp rep string nil literal)))
  82      (string-as-unibyte . identity)
  83      (string-make-unibyte . identity)
  84      ;; string-as-multibyte often doesn't really do what you think it does.
  85      ;; Example:
  86      ;;    (aref (string-as-multibyte "\201") 0) -> 129 (aka ?\201)
  87      ;;    (aref (string-as-multibyte "\300") 0) -> 192 (aka ?\300)
  88      ;;    (aref (string-as-multibyte "\300\201") 0) -> 192 (aka ?\300)
  89      ;;    (aref (string-as-multibyte "\300\201") 1) -> 129 (aka ?\201)
  90      ;; but
  91      ;;    (aref (string-as-multibyte "\201\300") 0) -> 2240
  92      ;;    (aref (string-as-multibyte "\201\300") 1) -> <error>
  93      ;; Better use string-to-multibyte or encode-coding-string.
  94      ;; If you really need string-as-multibyte somewhere it's usually
  95      ;; because you're using the internal emacs-mule representation (maybe
  96      ;; because you're using string-as-unibyte somewhere), which is
  97      ;; generally a problem in itself.
  98      ;; Here is an approximate equivalence table to help think about it:
  99      ;; (string-as-multibyte s)   ~= (decode-coding-string s 'emacs-mule)
 100      ;; (string-to-multibyte s)   ~= (decode-coding-string s 'binary)
 101      ;; (string-make-multibyte s) ~= (decode-coding-string s locale-coding-system)
 102      (string-as-multibyte . identity)
 103      (string-to-multibyte
 104       . (lambda (string)
 105           "Return a multibyte string with the same individual chars as string."
 106           (mapconcat
 107            (lambda (ch) (mm-string-as-multibyte (char-to-string ch)))
 108            string "")))
 109      (multibyte-string-p . ignore)
 110      (insert-byte . insert-char)
 111      (multibyte-char-to-unibyte . identity)
 112      (special-display-p
 113       . (lambda (buffer-name)
 114           "Returns non-nil if a buffer named BUFFER-NAME gets a special frame."
 115           (and special-display-function
 116                (or (and (member buffer-name special-display-buffer-names) t)
 117                    (cdr (assoc buffer-name special-display-buffer-names))
 118                    (catch 'return
 119                      (dolist (elem special-display-regexps)
 120                        (and (stringp elem)
 121                             (string-match elem buffer-name)
 122                             (throw 'return t))
 123                        (and (consp elem)
 124                             (stringp (car elem))
 125                             (string-match (car elem) buffer-name)
 126                             (throw 'return (cdr elem))))))))))))
 127
 128 (eval-and-compile
 129   (defalias 'mm-char-or-char-int-p
 130     (cond
 131      ((fboundp 'char-or-char-int-p) 'char-or-char-int-p)
 132      ((fboundp 'char-valid-p) 'char-valid-p)
 133      (t 'identity))))
 134
 135 ;; Fixme:  This seems always to be used to read a MIME charset, so it
 136 ;; should be re-named and fixed (in Emacs) to offer completion only on
 137 ;; proper charset names (base coding systems which have a
 138 ;; mime-charset defined).  XEmacs doesn't believe in mime-charset;
 139 ;; test with
 140 ;;   `(or (coding-system-get 'iso-8859-1 'mime-charset)
 141 ;;        (coding-system-get 'iso-8859-1 :mime-charset))'
 142 ;; Actually, there should be an `mm-coding-system-mime-charset'.
 143 (eval-and-compile
 144   (defalias 'mm-read-coding-system
 145     (cond
 146      ((fboundp 'read-coding-system)
 147       (if (and (featurep 'xemacs)
 148                (<= (string-to-number emacs-version) 21.1))
 149           (lambda (prompt &optional default-coding-system)
 150             (read-coding-system prompt))
 151         'read-coding-system))
 152      (t (lambda (prompt &optional default-coding-system)
 153           "Prompt the user for a coding system."
 154           (completing-read
 155            prompt (mapcar (lambda (s) (list (symbol-name (car s))))
 156                           mm-mime-mule-charset-alist)))))))
 157
 158 (defvar mm-coding-system-list nil)
 159 (defun mm-get-coding-system-list ()
 160   "Get the coding system list."
 161   (or mm-coding-system-list
 162       (setq mm-coding-system-list (mm-coding-system-list))))
 163
 164 (defun mm-coding-system-p (cs)
 165   "Return non-nil if CS is a symbol naming a coding system.
 166 In XEmacs, also return non-nil if CS is a coding system object.
 167 If CS is available, return CS itself in Emacs, and return a coding
 168 system object in XEmacs."
 169   (if (fboundp 'find-coding-system)
 170       (and cs (find-coding-system cs))
 171     (if (fboundp 'coding-system-p)
 172         (when (coding-system-p cs)
 173           cs)
 174       ;; no-MULE XEmacs:
 175       (car (memq cs (mm-get-coding-system-list))))))
 176
 177 (defun mm-codepage-setup (number &optional alias)
 178   "Create a coding system cpNUMBER.
 179 The coding system is created using `codepage-setup'.  If ALIAS is
 180 non-nil, an alias is created and added to
 181 `mm-charset-synonym-alist'.  If ALIAS is a string, it's used as
 182 the alias.  Else windows-NUMBER is used."
 183   (interactive
 184    (let ((completion-ignore-case t)
 185          (candidates (cp-supported-codepages)))
 186      (list (completing-read "Setup DOS Codepage: (default 437) " candidates
 187                             nil t nil nil "437"))))
 188   (when alias
 189     (setq alias (if (stringp alias)
 190                     (intern alias)
 191                   (intern (format "windows-%s" number)))))
 192   (let* ((cp (intern (format "cp%s" number))))
 193     (unless (mm-coding-system-p cp)
 194       (codepage-setup number))
 195     (when (and alias
 196                ;; Don't add alias if setup of cp failed.
 197                (mm-coding-system-p cp))
 198       (add-to-list 'mm-charset-synonym-alist (cons alias cp)))))
 199
 200 (defvar mm-charset-synonym-alist
 201   `(
 202     ;; Not in XEmacs, but it's not a proper MIME charset anyhow.
 203     ,@(unless (mm-coding-system-p 'x-ctext)
 204         '((x-ctext . ctext)))
 205     ;; ISO-8859-15 is very similar to ISO-8859-1.  But it's _different_!
 206     ,@(unless (mm-coding-system-p 'iso-8859-15)
 207         '((iso-8859-15 . iso-8859-1)))
 208     ;; BIG-5HKSCS is similar to, but different than, BIG-5.
 209     ,@(unless (mm-coding-system-p 'big5-hkscs)
 210         '((big5-hkscs . big5)))
 211     ;; Windows-1252 is actually a superset of Latin-1.  See also
 212     ;; `gnus-article-dumbquotes-map'.
 213     ,@(unless (mm-coding-system-p 'windows-1252)
 214         (if (mm-coding-system-p 'cp1252)
 215             '((windows-1252 . cp1252))
 216           '((windows-1252 . iso-8859-1))))
 217     ;; Windows-1250 is a variant of Latin-2 heavily used by Microsoft
 218     ;; Outlook users in Czech republic. Use this to allow reading of their
 219     ;; e-mails. cp1250 should be defined by M-x codepage-setup.
 220     ,@(if (and (not (mm-coding-system-p 'windows-1250))
 221                (mm-coding-system-p 'cp1250))
 222           '((windows-1250 . cp1250)))
 223     ;; A Microsoft misunderstanding.
 224     ,@(if (and (not (mm-coding-system-p 'unicode))
 225                (mm-coding-system-p 'utf-16-le))
 226           '((unicode . utf-16-le)))
 227     ;; A Microsoft misunderstanding.
 228     ,@(unless (mm-coding-system-p 'ks_c_5601-1987)
 229         (if (mm-coding-system-p 'cp949)
 230             '((ks_c_5601-1987 . cp949))
 231           '((ks_c_5601-1987 . euc-kr))))
 232     ;; Windows-31J is Windows Codepage 932.
 233     ,@(if (and (not (mm-coding-system-p 'windows-31j))
 234                (mm-coding-system-p 'cp932))
 235           '((windows-31j . cp932)))
 236     )
 237   "A mapping from unknown or invalid charset names to the real charset names.")
 238
 239 (defcustom mm-charset-override-alist
 240   `((iso-8859-1 . windows-1252))
 241   "A mapping from undesired charset names to their replacement.
 242
 243 You may add pairs like (iso-8859-1 . windows-1252) here,
 244 i.e. treat iso-8859-1 as windows-1252.  windows-1252 is a
 245 superset of iso-8859-1."
 246   :type '(list (set :inline t
 247                     (const (iso-8859-1 . windows-1252))
 248                     (const (undecided  . windows-1252)))
 249                (repeat :inline t
 250                        :tag "Other options"
 251                        (cons (symbol :tag "From charset")
 252                              (symbol :tag "To charset"))))
 253   :version "23.0" ;; No Gnus
 254   :group 'mime)
 255
 256 (defcustom mm-charset-eval-alist
 257   (if (featurep 'xemacs)
 258       nil ;; I don't know what would be useful for XEmacs.
 259     '(;; Emacs 21 offers 1250 1251 1253 1257.  Emacs 22 provides autoloads for
 260       ;; 1250-1258 (i.e. `mm-codepage-setup' does nothing).
 261       (windows-1250 . (mm-codepage-setup 1250 t))
 262       (windows-1251 . (mm-codepage-setup 1251 t))
 263       (windows-1253 . (mm-codepage-setup 1253 t))
 264       (windows-1257 . (mm-codepage-setup 1257 t))))
 265   "An alist of (CHARSET . FORM) pairs.
 266 If an article is encoded in an unknown CHARSET, FORM is
 267 evaluated.  This allows to load additional libraries providing
 268 charsets on demand.  If supported by your Emacs version, you
 269 could use `autoload-coding-system' here."
 270   :version "23.0" ;; No Gnus
 271   :type '(list (set :inline t
 272                     (const (windows-1250 . (mm-codepage-setup 1250 t)))
 273                     (const (windows-1251 . (mm-codepage-setup 1251 t)))
 274                     (const (windows-1253 . (mm-codepage-setup 1253 t)))
 275                     (const (windows-1257 . (mm-codepage-setup 1257 t)))
 276                     (const (cp850 . (mm-codepage-setup 850 nil))))
 277                (repeat :inline t
 278                        :tag "Other options"
 279                        (cons (symbol :tag "charset")
 280                              (symbol :tag "form"))))
 281   :group 'mime)
 282
 283 (defvar mm-binary-coding-system
 284   (cond
 285    ((mm-coding-system-p 'binary) 'binary)
 286    ((mm-coding-system-p 'no-conversion) 'no-conversion)
 287    (t nil))
 288   "100% binary coding system.")
 289
 290 (defvar mm-text-coding-system
 291   (or (if (memq system-type '(windows-nt ms-dos ms-windows))
 292           (and (mm-coding-system-p 'raw-text-dos) 'raw-text-dos)
 293         (and (mm-coding-system-p 'raw-text) 'raw-text))
 294       mm-binary-coding-system)
 295   "Text-safe coding system (For removing ^M).")
 296
 297 (defvar mm-text-coding-system-for-write nil
 298   "Text coding system for write.")
 299
 300 (defvar mm-auto-save-coding-system
 301   (cond
 302    ((mm-coding-system-p 'utf-8-emacs)   ; Mule 7
 303     (if (memq system-type '(windows-nt ms-dos ms-windows))
 304         (if (mm-coding-system-p 'utf-8-emacs-dos)
 305             'utf-8-emacs-dos mm-binary-coding-system)
 306       'utf-8-emacs))
 307    ((mm-coding-system-p 'emacs-mule)
 308     (if (memq system-type '(windows-nt ms-dos ms-windows))
 309         (if (mm-coding-system-p 'emacs-mule-dos)
 310             'emacs-mule-dos mm-binary-coding-system)
 311       'emacs-mule))
 312    ((mm-coding-system-p 'escape-quoted) 'escape-quoted)
 313    (t mm-binary-coding-system))
 314   "Coding system of auto save file.")
 315
 316 (defvar mm-universal-coding-system mm-auto-save-coding-system
 317   "The universal coding system.")
 318
 319 ;; Fixme: some of the cars here aren't valid MIME charsets.  That
 320 ;; should only matter with XEmacs, though.
 321 (defvar mm-mime-mule-charset-alist
 322   `((us-ascii ascii)
 323     (iso-8859-1 latin-iso8859-1)
 324     (iso-8859-2 latin-iso8859-2)
 325     (iso-8859-3 latin-iso8859-3)
 326     (iso-8859-4 latin-iso8859-4)
 327     (iso-8859-5 cyrillic-iso8859-5)
 328     ;; Non-mule (X)Emacs uses the last mule-charset for 8bit characters.
 329     ;; The fake mule-charset, gnus-koi8-r, tells Gnus that the default
 330     ;; charset is koi8-r, not iso-8859-5.
 331     (koi8-r cyrillic-iso8859-5 gnus-koi8-r)
 332     (iso-8859-6 arabic-iso8859-6)
 333     (iso-8859-7 greek-iso8859-7)
 334     (iso-8859-8 hebrew-iso8859-8)
 335     (iso-8859-9 latin-iso8859-9)
 336     (iso-8859-14 latin-iso8859-14)
 337     (iso-8859-15 latin-iso8859-15)
 338     (viscii vietnamese-viscii-lower)
 339     (iso-2022-jp latin-jisx0201 japanese-jisx0208 japanese-jisx0208-1978)
 340     (euc-kr korean-ksc5601)
 341     (gb2312 chinese-gb2312)
 342     (big5 chinese-big5-1 chinese-big5-2)
 343     (tibetan tibetan)
 344     (thai-tis620 thai-tis620)
 345     (windows-1251 cyrillic-iso8859-5)
 346     (iso-2022-7bit ethiopic arabic-1-column arabic-2-column)
 347     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
 348                    latin-jisx0201 japanese-jisx0208-1978
 349                    chinese-gb2312 japanese-jisx0208
 350                    korean-ksc5601 japanese-jisx0212)
 351     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
 352                     latin-jisx0201 japanese-jisx0208-1978
 353                     chinese-gb2312 japanese-jisx0208
 354                     korean-ksc5601 japanese-jisx0212
 355                     chinese-cns11643-1 chinese-cns11643-2)
 356     (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
 357                     cyrillic-iso8859-5 greek-iso8859-7
 358                     latin-jisx0201 japanese-jisx0208-1978
 359                     chinese-gb2312 japanese-jisx0208
 360                     korean-ksc5601 japanese-jisx0212
 361                     chinese-cns11643-1 chinese-cns11643-2
 362                     chinese-cns11643-3 chinese-cns11643-4
 363                     chinese-cns11643-5 chinese-cns11643-6
 364                     chinese-cns11643-7)
 365     (iso-2022-jp-3 latin-jisx0201 japanese-jisx0208-1978 japanese-jisx0208
 366                    japanese-jisx0213-1 japanese-jisx0213-2)
 367     (shift_jis latin-jisx0201 katakana-jisx0201 japanese-jisx0208)
 368     ,(cond ((fboundp 'unicode-precedence-list)
 369             (cons 'utf-8 (delq 'ascii (mapcar 'charset-name
 370                                               (unicode-precedence-list)))))
 371            ((or (not (fboundp 'charsetp)) ;; non-Mule case
 372                 (charsetp 'unicode-a)
 373                 (not (mm-coding-system-p 'mule-utf-8)))
 374             '(utf-8 unicode-a unicode-b unicode-c unicode-d unicode-e))
 375            (t ;; If we have utf-8 we're in Mule 5+.
 376             (append '(utf-8)
 377                     (delete 'ascii
 378                             (coding-system-get 'mule-utf-8 'safe-charsets))))))
 379   "Alist of MIME-charset/MULE-charsets.")
 380
 381 (defun mm-enrich-utf-8-by-mule-ucs ()
 382   "Make the `utf-8' MIME charset usable by the Mule-UCS package.
 383 This function will run when the `un-define' module is loaded under
 384 XEmacs, and fill the `utf-8' entry in `mm-mime-mule-charset-alist'
 385 with Mule charsets.  It is completely useless for Emacs."
 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 23 (unicode)
 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' and `mm-decode-string'.
 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
 908 NOTE: Use this macro with caution in multibyte buffers (it is not
 909 worth using this macro in unibyte buffers of course).  Use of
 910 `(set-buffer-multibyte t)', which is run finally, is generally
 911 harmful since it is likely to modify existing data in the buffer.
 912 For instance, it converts \"\\300\\255\" into \"\\255\" in
 913 Emacs 23 (unicode)."
 914   (let ((multibyte (make-symbol "multibyte"))
 915         (buffer (make-symbol "buffer")))
 916     `(if mm-emacs-mule
 917          (let ((,multibyte enable-multibyte-characters)
 918                (,buffer (current-buffer)))
 919            (unwind-protect
 920                (let (default-enable-multibyte-characters)
 921                  (set-buffer-multibyte nil)
 922                  ,@forms)
 923              (set-buffer ,buffer)
 924              (set-buffer-multibyte ,multibyte)))
 925        (let (default-enable-multibyte-characters)
 926          ,@forms))))
 927 (put 'mm-with-unibyte-current-buffer 'lisp-indent-function 0)
 928 (put 'mm-with-unibyte-current-buffer 'edebug-form-spec '(body))
 929
 930 (defmacro mm-with-unibyte (&rest forms)
 931   "Eval the FORMS with the default value of `enable-multibyte-characters' nil."
 932   `(let (default-enable-multibyte-characters)
 933      ,@forms))
 934 (put 'mm-with-unibyte 'lisp-indent-function 0)
 935 (put 'mm-with-unibyte 'edebug-form-spec '(body))
 936
 937 (defmacro mm-with-multibyte (&rest forms)
 938   "Eval the FORMS with the default value of `enable-multibyte-characters' t."
 939   `(let ((default-enable-multibyte-characters t))
 940      ,@forms))
 941 (put 'mm-with-multibyte 'lisp-indent-function 0)
 942 (put 'mm-with-multibyte 'edebug-form-spec '(body))
 943
 944 (defun mm-find-charset-region (b e)
 945   "Return a list of Emacs charsets in the region B to E."
 946   (cond
 947    ((and (mm-multibyte-p)
 948          (fboundp 'find-charset-region))
 949     ;; Remove composition since the base charsets have been included.
 950     ;; Remove eight-bit-*, treat them as ascii.
 951     (let ((css (find-charset-region b e)))
 952       (mapcar (lambda (cs) (setq css (delq cs css)))
 953               '(composition eight-bit-control eight-bit-graphic
 954                             control-1))
 955       css))
 956    (t
 957     ;; We are in a unibyte buffer or XEmacs non-mule, so we futz around a bit.
 958     (save-excursion
 959       (save-restriction
 960         (narrow-to-region b e)
 961         (goto-char (point-min))
 962         (skip-chars-forward "\0-\177")
 963         (if (eobp)
 964             '(ascii)
 965           (let (charset)
 966             (setq charset
 967                   (and (boundp 'current-language-environment)
 968                        (car (last (assq 'charset
 969                                         (assoc current-language-environment
 970                                                language-info-alist))))))
 971             (if (eq charset 'ascii) (setq charset nil))
 972             (or charset
 973                 (setq charset
 974                       (car (last (assq mail-parse-charset
 975                                        mm-mime-mule-charset-alist)))))
 976             (list 'ascii (or charset 'latin-iso8859-1)))))))))
 977
 978 (defun mm-auto-mode-alist ()
 979   "Return an `auto-mode-alist' with only the .gz (etc) thingies."
 980   (let ((alist auto-mode-alist)
 981         out)
 982     (while alist
 983       (when (listp (cdar alist))
 984         (push (car alist) out))
 985       (pop alist))
 986     (nreverse out)))
 987
 988 (defvar mm-inhibit-file-name-handlers
 989   '(jka-compr-handler image-file-handler)
 990   "A list of handlers doing (un)compression (etc) thingies.")
 991
 992 (defun mm-insert-file-contents (filename &optional visit beg end replace
 993                                          inhibit)
 994   "Like `insert-file-contents', but only reads in the file.
 995 A buffer may be modified in several ways after reading into the buffer due
 996 to advanced Emacs features, such as file-name-handlers, format decoding,
 997 `find-file-hooks', etc.
 998 If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'.
 999   This function ensures that none of these modifications will take place."
1000   (let* ((format-alist nil)
1001          (auto-mode-alist (if inhibit nil (mm-auto-mode-alist)))
1002          (default-major-mode 'fundamental-mode)
1003          (enable-local-variables nil)
1004          (after-insert-file-functions nil)
1005          (enable-local-eval nil)
1006          (inhibit-file-name-operation (if inhibit
1007                                           'insert-file-contents
1008                                         inhibit-file-name-operation))
1009          (inhibit-file-name-handlers
1010           (if inhibit
1011               (append mm-inhibit-file-name-handlers
1012                       inhibit-file-name-handlers)
1013             inhibit-file-name-handlers))
1014          (ffh (if (boundp 'find-file-hook)
1015                   'find-file-hook
1016                 'find-file-hooks))
1017          (val (symbol-value ffh)))
1018     (set ffh nil)
1019     (unwind-protect
1020         (insert-file-contents filename visit beg end replace)
1021       (set ffh val))))
1022
1023 (defun mm-append-to-file (start end filename &optional codesys inhibit)
1024   "Append the contents of the region to the end of file FILENAME.
1025 When called from a function, expects three arguments,
1026 START, END and FILENAME.  START and END are buffer positions
1027 saying what text to write.
1028 Optional fourth argument specifies the coding system to use when
1029 encoding the file.
1030 If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'."
1031   (let ((coding-system-for-write
1032          (or codesys mm-text-coding-system-for-write
1033              mm-text-coding-system))
1034         (inhibit-file-name-operation (if inhibit
1035                                          'append-to-file
1036                                        inhibit-file-name-operation))
1037         (inhibit-file-name-handlers
1038          (if inhibit
1039              (append mm-inhibit-file-name-handlers
1040                      inhibit-file-name-handlers)
1041            inhibit-file-name-handlers)))
1042     (write-region start end filename t 'no-message)
1043     (message "Appended to %s" filename)))
1044
1045 (defun mm-write-region (start end filename &optional append visit lockname
1046                               coding-system inhibit)
1047
1048   "Like `write-region'.
1049 If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'."
1050   (let ((coding-system-for-write
1051          (or coding-system mm-text-coding-system-for-write
1052              mm-text-coding-system))
1053         (inhibit-file-name-operation (if inhibit
1054                                          'write-region
1055                                        inhibit-file-name-operation))
1056         (inhibit-file-name-handlers
1057          (if inhibit
1058              (append mm-inhibit-file-name-handlers
1059                      inhibit-file-name-handlers)
1060            inhibit-file-name-handlers)))
1061     (write-region start end filename append visit lockname)))
1062
1063 ;; It is not a MIME function, but some MIME functions use it.
1064 (if (and (fboundp 'make-temp-file)
1065          (ignore-errors
1066            (let ((def (symbol-function 'make-temp-file)))
1067              (and (byte-code-function-p def)
1068                   (setq def (if (fboundp 'compiled-function-arglist)
1069                                 ;; XEmacs
1070                                 (eval (list 'compiled-function-arglist def))
1071                               (aref def 0)))
1072                   (>= (length def) 4)
1073                   (eq (nth 3 def) 'suffix)))))
1074     (defalias 'mm-make-temp-file 'make-temp-file)
1075   ;; Stolen (and modified for XEmacs) from Emacs 22.
1076   (defun mm-make-temp-file (prefix &optional dir-flag suffix)
1077     "Create a temporary file.
1078 The returned file name (created by appending some random characters at the end
1079 of PREFIX, and expanding against `temporary-file-directory' if necessary),
1080 is guaranteed to point to a newly created empty file.
1081 You can then use `write-region' to write new data into the file.
1082
1083 If DIR-FLAG is non-nil, create a new empty directory instead of a file.
1084
1085 If SUFFIX is non-nil, add that at the end of the file name."
1086     (let ((umask (default-file-modes))
1087           file)
1088       (unwind-protect
1089           (progn
1090             ;; Create temp files with strict access rights.  It's easy to
1091             ;; loosen them later, whereas it's impossible to close the
1092             ;; time-window of loose permissions otherwise.
1093             (set-default-file-modes 448)
1094             (while (condition-case err
1095                        (progn
1096                          (setq file
1097                                (make-temp-name
1098                                 (expand-file-name
1099                                  prefix
1100                                  (if (fboundp 'temp-directory)
1101                                      ;; XEmacs
1102                                      (temp-directory)
1103                                    temporary-file-directory))))
1104                          (if suffix
1105                              (setq file (concat file suffix)))
1106                          (if dir-flag
1107                              (make-directory file)
1108                            (if (featurep 'xemacs)
1109                                ;; NOTE: This is unsafe if XEmacs users
1110                                ;; don't use a secure temp directory.
1111                                (if (file-exists-p file)
1112                                    (signal 'file-already-exists
1113                                            (list "File exists" file))
1114                                  (write-region "" nil file nil 'silent))
1115                              (write-region "" nil file nil 'silent
1116                                            nil 'excl)))
1117                          nil)
1118                      (file-already-exists t)
1119                      ;; The XEmacs version of `make-directory' issues
1120                      ;; `file-error'.
1121                      (file-error (or (and (featurep 'xemacs)
1122                                           (file-exists-p file))
1123                                      (signal (car err) (cdr err)))))
1124               ;; the file was somehow created by someone else between
1125               ;; `make-temp-name' and `write-region', let's try again.
1126               nil)
1127             file)
1128         ;; Reset the umask.
1129         (set-default-file-modes umask)))))
1130
1131 (defun mm-image-load-path (&optional package)
1132   (let (dir result)
1133     (dolist (path load-path (nreverse result))
1134       (when (and path
1135                  (file-directory-p
1136                   (setq dir (concat (file-name-directory
1137                                      (directory-file-name path))
1138                                     "etc/images/" (or package "gnus/")))))
1139         (push dir result))
1140       (push path result))))
1141
1142 ;; Fixme: This doesn't look useful where it's used.
1143 (if (fboundp 'detect-coding-region)
1144     (defun mm-detect-coding-region (start end)
1145       "Like `detect-coding-region' except returning the best one."
1146       (let ((coding-systems
1147              (detect-coding-region start end)))
1148         (or (car-safe coding-systems)
1149             coding-systems)))
1150   (defun mm-detect-coding-region (start end)
1151     (let ((point (point)))
1152       (goto-char start)
1153       (skip-chars-forward "\0-\177" end)
1154       (prog1
1155           (if (eq (point) end) 'ascii (mm-guess-charset))
1156         (goto-char point)))))
1157
1158 (if (fboundp 'coding-system-get)
1159     (defun mm-detect-mime-charset-region (start end)
1160       "Detect MIME charset of the text in the region between START and END."
1161       (let ((cs (mm-detect-coding-region start end)))
1162         (or (coding-system-get cs :mime-charset)
1163             (coding-system-get cs 'mime-charset))))
1164   (defun mm-detect-mime-charset-region (start end)
1165     "Detect MIME charset of the text in the region between START and END."
1166     (let ((cs (mm-detect-coding-region start end)))
1167       cs)))
1168
1169 (eval-when-compile
1170   (unless (fboundp 'coding-system-to-mime-charset)
1171     (defalias 'coding-system-to-mime-charset 'ignore)))
1172
1173 (defun mm-coding-system-to-mime-charset (coding-system)
1174   "Return the MIME charset corresponding to CODING-SYSTEM.
1175 To make this function work with XEmacs, the APEL package is required."
1176   (when coding-system
1177     (or (and (fboundp 'coding-system-get)
1178              (or (coding-system-get coding-system :mime-charset)
1179                  (coding-system-get coding-system 'mime-charset)))
1180         (and (featurep 'xemacs)
1181              (or (and (fboundp 'coding-system-to-mime-charset)
1182                       (not (eq (symbol-function 'coding-system-to-mime-charset)
1183                                'ignore)))
1184                  (and (condition-case nil
1185                           (require 'mcharset)
1186                         (error nil))
1187                       (fboundp 'coding-system-to-mime-charset)))
1188              (coding-system-to-mime-charset coding-system)))))
1189
1190 (eval-when-compile
1191   (require 'jka-compr))
1192
1193 (defun mm-decompress-buffer (filename &optional inplace force)
1194   "Decompress buffer's contents, depending on jka-compr.
1195 Only when FORCE is t or `auto-compression-mode' is enabled and FILENAME
1196 agrees with `jka-compr-compression-info-list', decompression is done.
1197 Signal an error if FORCE is neither nil nor t and compressed data are
1198 not decompressed because `auto-compression-mode' is disabled.
1199 If INPLACE is nil, return decompressed data or nil without modifying
1200 the buffer.  Otherwise, replace the buffer's contents with the
1201 decompressed data.  The buffer's multibyteness must be turned off."
1202   (when (and filename
1203              (if force
1204                  (prog1 t (require 'jka-compr))
1205                (and (fboundp 'jka-compr-installed-p)
1206                     (jka-compr-installed-p))))
1207     (let ((info (jka-compr-get-compression-info filename)))
1208       (when info
1209         (unless (or (memq force (list nil t))
1210                     (jka-compr-installed-p))
1211           (error ""))
1212         (let ((prog (jka-compr-info-uncompress-program info))
1213               (args (jka-compr-info-uncompress-args info))
1214               (msg (format "%s %s..."
1215                            (jka-compr-info-uncompress-message info)
1216                            filename))
1217               (err-file (jka-compr-make-temp-name))
1218               (cur (current-buffer))
1219               (coding-system-for-read mm-binary-coding-system)
1220               (coding-system-for-write mm-binary-coding-system)
1221               retval err-msg)
1222           (message "%s" msg)
1223           (mm-with-unibyte-buffer
1224             (insert-buffer-substring cur)
1225             (condition-case err
1226                 (progn
1227                   (unless (memq (apply 'call-process-region
1228                                        (point-min) (point-max)
1229                                        prog t (list t err-file) nil args)
1230                                 jka-compr-acceptable-retval-list)
1231                     (erase-buffer)
1232                     (insert (mapconcat
1233                              'identity
1234                              (delete "" (split-string
1235                                          (prog2
1236                                              (insert-file-contents err-file)
1237                                              (buffer-string)
1238                                            (erase-buffer))))
1239                              " ")
1240                             "\n")
1241                     (setq err-msg
1242                           (format "Error while executing \"%s %s < %s\""
1243                                   prog (mapconcat 'identity args " ")
1244                                   filename)))
1245                   (setq retval (buffer-string)))
1246               (error
1247                (setq err-msg (error-message-string err)))))
1248           (when (file-exists-p err-file)
1249             (ignore-errors (jka-compr-delete-temp-file err-file)))
1250           (when inplace
1251             (unless err-msg
1252               (delete-region (point-min) (point-max))
1253               (insert retval))
1254             (setq retval nil))
1255           (message "%s" (or err-msg (concat msg "done")))
1256           retval)))))
1257
1258 (eval-when-compile
1259   (unless (fboundp 'coding-system-name)
1260     (defalias 'coding-system-name 'ignore))
1261   (unless (fboundp 'find-file-coding-system-for-read-from-filename)
1262     (defalias 'find-file-coding-system-for-read-from-filename 'ignore))
1263   (unless (fboundp 'find-operation-coding-system)
1264     (defalias 'find-operation-coding-system 'ignore)))
1265
1266 (defun mm-find-buffer-file-coding-system (&optional filename)
1267   "Find coding system used to decode the contents of the current buffer.
1268 This function looks for the coding system magic cookie or examines the
1269 coding system specified by `file-coding-system-alist' being associated
1270 with FILENAME which defaults to `buffer-file-name'.  Data compressed by
1271 gzip, bzip2, etc. are allowed."
1272   (unless filename
1273     (setq filename buffer-file-name))
1274   (save-excursion
1275     (let ((decomp (unless ;; No worth to examine charset of tar files.
1276                       (and filename
1277                            (string-match
1278                             "\\.\\(?:tar\\.[^.]+\\|tbz\\|tgz\\)\\'"
1279                             filename))
1280                     (mm-decompress-buffer filename nil t))))
1281       (when decomp
1282         (set-buffer (let (default-enable-multibyte-characters)
1283                       (generate-new-buffer " *temp*")))
1284         (insert decomp)
1285         (setq filename (file-name-sans-extension filename)))
1286       (goto-char (point-min))
1287       (prog1
1288           (cond
1289            ((boundp 'set-auto-coding-function) ;; Emacs
1290             (if filename
1291                 (or (funcall (symbol-value 'set-auto-coding-function)
1292                              filename (- (point-max) (point-min)))
1293                     (car (find-operation-coding-system 'insert-file-contents
1294                                                        filename)))
1295               (let (auto-coding-alist)
1296                 (condition-case nil
1297                     (funcall (symbol-value 'set-auto-coding-function)
1298                              nil (- (point-max) (point-min)))
1299                   (error nil)))))
1300            ((featurep 'file-coding) ;; XEmacs
1301             (let ((case-fold-search t)
1302                   (end (point-at-eol))
1303                   codesys start)
1304               (or
1305                (and (re-search-forward "-\\*-+[\t ]*" end t)
1306                     (progn
1307                       (setq start (match-end 0))
1308                       (re-search-forward "[\t ]*-+\\*-" end t))
1309                     (progn
1310                       (setq end (match-beginning 0))
1311                       (goto-char start)
1312                       (or (looking-at "coding:[\t ]*\\([^\t ;]+\\)")
1313                           (re-search-forward
1314                            "[\t ;]+coding:[\t ]*\\([^\t ;]+\\)"
1315                            end t)))
1316                     (find-coding-system (setq codesys
1317                                               (intern (match-string 1))))
1318                     codesys)
1319                (and (re-search-forward "^[\t ]*;+[\t ]*Local[\t ]+Variables:"
1320                                        nil t)
1321                     (progn
1322                       (setq start (match-end 0))
1323                       (re-search-forward "^[\t ]*;+[\t ]*End:" nil t))
1324                     (progn
1325                       (setq end (match-beginning 0))
1326                       (goto-char start)
1327                       (re-search-forward
1328                        "^[\t ]*;+[\t ]*coding:[\t ]*\\([^\t\n\r ]+\\)"
1329                        end t))
1330                     (find-coding-system (setq codesys
1331                                               (intern (match-string 1))))
1332                     codesys)
1333                (and (progn
1334                       (goto-char (point-min))
1335                       (setq case-fold-search nil)
1336                       (re-search-forward "^;;;coding system: "
1337                                          ;;(+ (point-min) 3000) t))
1338                                          nil t))
1339                     (looking-at "[^\t\n\r ]+")
1340                     (find-coding-system
1341                      (setq codesys (intern (match-string 0))))
1342                     codesys)
1343                (and filename
1344                     (setq codesys
1345                           (find-file-coding-system-for-read-from-filename
1346                            filename))
1347                     (coding-system-name (coding-system-base codesys)))))))
1348         (when decomp
1349           (kill-buffer (current-buffer)))))))
1350
1351 (provide 'mm-util)
1352
1353 ;; arch-tag: 94dc5388-825d-4fd1-bfa5-2100aa351238
1354 ;;; mm-util.el ends here