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                                             allow-override)
 493   "Return coding-system corresponding to CHARSET.
 494 CHARSET is a symbol naming a MIME charset.
 495 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
 496 used as the line break code type of the coding system.
 497
 498 If ALLOW-OVERRIDE is given, use `mm-charset-override-alist' to
 499 map undesired charset names to their replacement.  This should
 500 only be used for decoding, not for encoding."
 501   ;; OVERRIDE is used (only) in `mm-decode-body'.
 502   (when (stringp charset)
 503     (setq charset (intern (downcase charset))))
 504   (when lbt
 505     (setq charset (intern (format "%s-%s" charset lbt))))
 506   (cond
 507    ((null charset)
 508     charset)
 509    ;; Running in a non-MULE environment.
 510    ((or (null (mm-get-coding-system-list))
 511         (not (fboundp 'coding-system-get)))
 512     charset)
 513    ;; Check override list quite early.  Should only used for decoding, not for
 514    ;; encoding!
 515    ((and allow-override
 516          (let ((cs (cdr (assq charset mm-charset-override-alist))))
 517            (and cs (mm-coding-system-p cs) cs))))
 518    ;; ascii
 519    ((eq charset 'us-ascii)
 520     'ascii)
 521    ;; Check to see whether we can handle this charset.  (This depends
 522    ;; on there being some coding system matching each `mime-charset'
 523    ;; property defined, as there should be.)
 524    ((and (mm-coding-system-p charset)
 525 ;;; Doing this would potentially weed out incorrect charsets.
 526 ;;;      charset
 527 ;;;      (eq charset (coding-system-get charset 'mime-charset))
 528          )
 529     charset)
 530    ;; Eval expressions from `mm-charset-eval-alist'
 531    ((let* ((el (assq charset mm-charset-eval-alist))
 532            (cs (car el))
 533            (form (cdr el)))
 534       (and cs
 535            form
 536            (prog2
 537                ;; Avoid errors...
 538                (condition-case nil (eval form) (error nil))
 539                ;; (message "Failed to eval `%s'" form))
 540                (mm-coding-system-p cs)
 541              (message "Added charset `%s' via `mm-charset-eval-alist'" cs))
 542            cs)))
 543    ;; Translate invalid charsets.
 544    ((let ((cs (cdr (assq charset mm-charset-synonym-alist))))
 545       (and cs
 546            (mm-coding-system-p cs)
 547            ;; (message
 548            ;;  "Using synonym `%s' from `mm-charset-synonym-alist' for `%s'"
 549            ;;  cs charset)
 550            cs)))
 551    ;; Last resort: search the coding system list for entries which
 552    ;; have the right mime-charset in case the canonical name isn't
 553    ;; defined (though it should be).
 554    ((let (cs)
 555       ;; mm-get-coding-system-list returns a list of cs without lbt.
 556       ;; Do we need -lbt?
 557       (dolist (c (mm-get-coding-system-list))
 558         (if (and (null cs)
 559                  (eq charset (or (coding-system-get c :mime-charset)
 560                                  (coding-system-get c 'mime-charset))))
 561             (setq cs c)))
 562       (unless cs
 563         ;; Warn the user about unknown charset:
 564         (if (fboundp 'gnus-message)
 565             (gnus-message 7 "Unknown charset: %s" charset)
 566           (message "Unknown charset: %s" charset)))
 567       cs))))
 568
 569 (eval-and-compile
 570   (defvar mm-emacs-mule (and (not (featurep 'xemacs))
 571                              (boundp 'default-enable-multibyte-characters)
 572                              default-enable-multibyte-characters
 573                              (fboundp 'set-buffer-multibyte))
 574     "True in Emacs with Mule.")
 575
 576   (if mm-emacs-mule
 577       (defun mm-enable-multibyte ()
 578         "Set the multibyte flag of the current buffer.
 579 Only do this if the default value of `enable-multibyte-characters' is
 580 non-nil.  This is a no-op in XEmacs."
 581         (set-buffer-multibyte 'to))
 582     (defalias 'mm-enable-multibyte 'ignore))
 583
 584   (if mm-emacs-mule
 585       (defun mm-disable-multibyte ()
 586         "Unset the multibyte flag of in the current buffer.
 587 This is a no-op in XEmacs."
 588         (set-buffer-multibyte nil))
 589     (defalias 'mm-disable-multibyte 'ignore)))
 590
 591 (defun mm-preferred-coding-system (charset)
 592   ;; A typo in some Emacs versions.
 593   (or (get-charset-property charset 'preferred-coding-system)
 594       (get-charset-property charset 'prefered-coding-system)))
 595
 596 ;; Mule charsets shouldn't be used.
 597 (defsubst mm-guess-charset ()
 598   "Guess Mule charset from the language environment."
 599   (or
 600    mail-parse-mule-charset ;; cached mule-charset
 601    (progn
 602      (setq mail-parse-mule-charset
 603            (and (boundp 'current-language-environment)
 604                 (car (last
 605                       (assq 'charset
 606                             (assoc current-language-environment
 607                                    language-info-alist))))))
 608      (if (or (not mail-parse-mule-charset)
 609              (eq mail-parse-mule-charset 'ascii))
 610          (setq mail-parse-mule-charset
 611                (or (car (last (assq mail-parse-charset
 612                                     mm-mime-mule-charset-alist)))
 613                    ;; default
 614                    'latin-iso8859-1)))
 615      mail-parse-mule-charset)))
 616
 617 (defun mm-charset-after (&optional pos)
 618   "Return charset of a character in current buffer at position POS.
 619 If POS is nil, it defauls to the current point.
 620 If POS is out of range, the value is nil.
 621 If the charset is `composition', return the actual one."
 622   (let ((char (char-after pos)) charset)
 623     (if (< (mm-char-int char) 128)
 624         (setq charset 'ascii)
 625       ;; charset-after is fake in some Emacsen.
 626       (setq charset (and (fboundp 'char-charset) (char-charset char)))
 627       (if (eq charset 'composition)     ; Mule 4
 628           (let ((p (or pos (point))))
 629             (cadr (find-charset-region p (1+ p))))
 630         (if (and charset (not (memq charset '(ascii eight-bit-control
 631                                                     eight-bit-graphic))))
 632             charset
 633           (mm-guess-charset))))))
 634
 635 (defun mm-mime-charset (charset)
 636   "Return the MIME charset corresponding to the given Mule CHARSET."
 637   (if (eq charset 'unknown)
 638       (error "The message contains non-printable characters, please use attachment"))
 639   (if (and (fboundp 'coding-system-get) (fboundp 'get-charset-property))
 640       ;; This exists in Emacs 20.
 641       (or
 642        (and (mm-preferred-coding-system charset)
 643             (or (coding-system-get
 644                  (mm-preferred-coding-system charset) :mime-charset)
 645                 (coding-system-get
 646                  (mm-preferred-coding-system charset) 'mime-charset)))
 647        (and (eq charset 'ascii)
 648             'us-ascii)
 649        (mm-preferred-coding-system charset)
 650        (mm-mule-charset-to-mime-charset charset))
 651     ;; This is for XEmacs.
 652     (mm-mule-charset-to-mime-charset charset)))
 653
 654 (if (fboundp 'delete-dups)
 655     (defalias 'mm-delete-duplicates 'delete-dups)
 656   (defun mm-delete-duplicates (list)
 657     "Destructively remove `equal' duplicates from LIST.
 658 Store the result in LIST and return it.  LIST must be a proper list.
 659 Of several `equal' occurrences of an element in LIST, the first
 660 one is kept.
 661
 662 This is a compatibility function for Emacsen without `delete-dups'."
 663     ;; Code from `subr.el' in Emacs 22:
 664     (let ((tail list))
 665       (while tail
 666         (setcdr tail (delete (car tail) (cdr tail)))
 667         (setq tail (cdr tail))))
 668     list))
 669
 670 ;; Fixme:  This is used in places when it should be testing the
 671 ;; default multibyteness.  See mm-default-multibyte-p.
 672 (eval-and-compile
 673   (if (and (not (featurep 'xemacs))
 674            (boundp 'enable-multibyte-characters))
 675       (defun mm-multibyte-p ()
 676         "Non-nil if multibyte is enabled in the current buffer."
 677         enable-multibyte-characters)
 678     (defun mm-multibyte-p () (featurep 'mule))))
 679
 680 (defun mm-default-multibyte-p ()
 681   "Return non-nil if the session is multibyte.
 682 This affects whether coding conversion should be attempted generally."
 683   (if (featurep 'mule)
 684       (if (boundp 'default-enable-multibyte-characters)
 685           default-enable-multibyte-characters
 686         t)))
 687
 688 (defun mm-iso-8859-x-to-15-region (&optional b e)
 689   (if (fboundp 'char-charset)
 690       (let (charset item c inconvertible)
 691         (save-restriction
 692           (if e (narrow-to-region b e))
 693           (goto-char (point-min))
 694           (skip-chars-forward "\0-\177")
 695           (while (not (eobp))
 696             (cond
 697              ((not (setq item (assq (char-charset (setq c (char-after)))
 698                                     mm-iso-8859-x-to-15-table)))
 699               (forward-char))
 700              ((memq c (cdr (cdr item)))
 701               (setq inconvertible t)
 702               (forward-char))
 703              (t
 704               (insert-before-markers (prog1 (+ c (car (cdr item)))
 705                                        (delete-char 1)))))
 706             (skip-chars-forward "\0-\177")))
 707         (not inconvertible))))
 708
 709 (defun mm-sort-coding-systems-predicate (a b)
 710   (let ((priorities
 711          (mapcar (lambda (cs)
 712                    ;; Note: invalid entries are dropped silently
 713                    (and (setq cs (mm-coding-system-p cs))
 714                         (coding-system-base cs)))
 715                  mm-coding-system-priorities)))
 716     (and (setq a (mm-coding-system-p a))
 717          (if (setq b (mm-coding-system-p b))
 718              (> (length (memq (coding-system-base a) priorities))
 719                 (length (memq (coding-system-base b) priorities)))
 720            t))))
 721
 722 (eval-when-compile
 723   (autoload 'latin-unity-massage-name "latin-unity")
 724   (autoload 'latin-unity-maybe-remap "latin-unity")
 725   (autoload 'latin-unity-representations-feasible-region "latin-unity")
 726   (autoload 'latin-unity-representations-present-region "latin-unity")
 727   (defvar latin-unity-coding-systems)
 728   (defvar latin-unity-ucs-list))
 729
 730 (defun mm-xemacs-find-mime-charset-1 (begin end)
 731   "Determine which MIME charset to use to send region as message.
 732 This uses the XEmacs-specific latin-unity package to better handle the
 733 case where identical characters from diverse ISO-8859-? character sets
 734 can be encoded using a single one of the corresponding coding systems.
 735
 736 It treats `mm-coding-system-priorities' as the list of preferred
 737 coding systems; a useful example setting for this list in Western
 738 Europe would be '(iso-8859-1 iso-8859-15 utf-8), which would default
 739 to the very standard Latin 1 coding system, and only move to coding
 740 systems that are less supported as is necessary to encode the
 741 characters that exist in the buffer.
 742
 743 Latin Unity doesn't know about those non-ASCII Roman characters that
 744 are available in various East Asian character sets.  As such, its
 745 behavior if you have a JIS 0212 LATIN SMALL LETTER A WITH ACUTE in a
 746 buffer and it can otherwise be encoded as Latin 1, won't be ideal.
 747 But this is very much a corner case, so don't worry about it."
 748   (let ((systems mm-coding-system-priorities) csets psets curset)
 749
 750     ;; Load the Latin Unity library, if available.
 751     (when (and (not (featurep 'latin-unity)) (locate-library "latin-unity"))
 752       (require 'latin-unity))
 753
 754     ;; Now, can we use it?
 755     (if (featurep 'latin-unity)
 756         (progn
 757           (setq csets (latin-unity-representations-feasible-region begin end)
 758                 psets (latin-unity-representations-present-region begin end))
 759
 760           (catch 'done
 761
 762             ;; Pass back the first coding system in the preferred list
 763             ;; that can encode the whole region.
 764             (dolist (curset systems)
 765               (setq curset (latin-unity-massage-name 'buffer-default curset))
 766
 767               ;; If the coding system is a universal coding system, then
 768               ;; it can certainly encode all the characters in the region.
 769               (if (memq curset latin-unity-ucs-list)
 770                   (throw 'done (list curset)))
 771
 772               ;; If a coding system isn't universal, and isn't in
 773               ;; the list that latin unity knows about, we can't
 774               ;; decide whether to use it here. Leave that until later
 775               ;; in `mm-find-mime-charset-region' function, whence we
 776               ;; have been called.
 777               (unless (memq curset latin-unity-coding-systems)
 778                 (throw 'done nil))
 779
 780               ;; Right, we know about this coding system, and it may
 781               ;; conceivably be able to encode all the characters in
 782               ;; the region.
 783               (if (latin-unity-maybe-remap begin end curset csets psets t)
 784                   (throw 'done (list curset))))
 785
 786             ;; Can't encode using anything from the
 787             ;; `mm-coding-system-priorities' list.
 788             ;; Leave `mm-find-mime-charset' to do most of the work.
 789             nil))
 790
 791       ;; Right, latin unity isn't available; let `mm-find-charset-region'
 792       ;; take its default action, which equally applies to GNU Emacs.
 793       nil)))
 794
 795 (defmacro mm-xemacs-find-mime-charset (begin end)
 796   (when (featurep 'xemacs)
 797     `(and (featurep 'mule) (mm-xemacs-find-mime-charset-1 ,begin ,end))))
 798
 799 (defun mm-find-mime-charset-region (b e &optional hack-charsets)
 800   "Return the MIME charsets needed to encode the region between B and E.
 801 nil means ASCII, a single-element list represents an appropriate MIME
 802 charset, and a longer list means no appropriate charset."
 803   (let (charsets)
 804     ;; The return possibilities of this function are a mess...
 805     (or (and (mm-multibyte-p)
 806              mm-use-find-coding-systems-region
 807              ;; Find the mime-charset of the most preferred coding
 808              ;; system that has one.
 809              (let ((systems (find-coding-systems-region b e)))
 810                (when mm-coding-system-priorities
 811                  (setq systems
 812                        (sort systems 'mm-sort-coding-systems-predicate)))
 813                (setq systems (delq 'compound-text systems))
 814                (unless (equal systems '(undecided))
 815                  (while systems
 816                    (let* ((head (pop systems))
 817                           (cs (or (coding-system-get head :mime-charset)
 818                                   (coding-system-get head 'mime-charset))))
 819                      ;; The mime-charset (`x-ctext') of
 820                      ;; `compound-text' is not in the IANA list.  We
 821                      ;; shouldn't normally use anything here with a
 822                      ;; mime-charset having an `x-' prefix.
 823                      ;; Fixme:  Allow this to be overridden, since
 824                      ;; there is existing use of x-ctext.
 825                      ;; Also people apparently need the coding system
 826                      ;; `iso-2022-jp-3' (which Mule-UCS defines with
 827                      ;; mime-charset, though it's not valid).
 828                      (if (and cs
 829                               (not (string-match "^[Xx]-" (symbol-name cs)))
 830                               ;; UTF-16 of any variety is invalid for
 831                               ;; text parts and, unfortunately, has
 832                               ;; mime-charset defined both in Mule-UCS
 833                               ;; and versions of Emacs.  (The name
 834                               ;; might be `mule-utf-16...'  or
 835                               ;; `utf-16...'.)
 836                               (not (string-match "utf-16" (symbol-name cs))))
 837                          (setq systems nil
 838                                charsets (list cs))))))
 839                charsets))
 840         ;; If we're XEmacs, and some coding system is appropriate,
 841         ;; mm-xemacs-find-mime-charset will return an appropriate list.
 842         ;; Otherwise, we'll get nil, and the next setq will get invoked.
 843         (setq charsets (mm-xemacs-find-mime-charset b e))
 844
 845         ;; We're not multibyte, or a single coding system won't cover it.
 846         (setq charsets
 847               (mm-delete-duplicates
 848                (mapcar 'mm-mime-charset
 849                        (delq 'ascii
 850                              (mm-find-charset-region b e))))))
 851     (if (and (> (length charsets) 1)
 852              (memq 'iso-8859-15 charsets)
 853              (memq 'iso-8859-15 hack-charsets)
 854              (save-excursion (mm-iso-8859-x-to-15-region b e)))
 855         (mapcar (lambda (x) (setq charsets (delq (car x) charsets)))
 856                 mm-iso-8859-15-compatible))
 857     (if (and (memq 'iso-2022-jp-2 charsets)
 858              (memq 'iso-2022-jp-2 hack-charsets))
 859         (setq charsets (delq 'iso-2022-jp charsets)))
 860     ;; Attempt to reduce the number of charsets if utf-8 is available.
 861     (if (and (featurep 'xemacs)
 862              (> (length charsets) 1)
 863              (mm-coding-system-p 'utf-8))
 864         (let ((mm-coding-system-priorities
 865                (cons 'utf-8 mm-coding-system-priorities)))
 866           (setq charsets
 867                 (mm-delete-duplicates
 868                  (mapcar 'mm-mime-charset
 869                          (delq 'ascii
 870                                (mm-find-charset-region b e)))))))
 871     charsets))
 872
 873 (defmacro mm-with-unibyte-buffer (&rest forms)
 874   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 875 Use unibyte mode for this."
 876   `(let (default-enable-multibyte-characters)
 877      (with-temp-buffer ,@forms)))
 878 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
 879 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
 880
 881 (defmacro mm-with-multibyte-buffer (&rest forms)
 882   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 883 Use multibyte mode for this."
 884   `(let ((default-enable-multibyte-characters t))
 885      (with-temp-buffer ,@forms)))
 886 (put 'mm-with-multibyte-buffer 'lisp-indent-function 0)
 887 (put 'mm-with-multibyte-buffer 'edebug-form-spec '(body))
 888
 889 (defmacro mm-with-unibyte-current-buffer (&rest forms)
 890   "Evaluate FORMS with current buffer temporarily made unibyte.
 891 Also bind `default-enable-multibyte-characters' to nil.
 892 Equivalent to `progn' in XEmacs"
 893   (let ((multibyte (make-symbol "multibyte"))
 894         (buffer (make-symbol "buffer")))
 895     `(if mm-emacs-mule
 896          (let ((,multibyte enable-multibyte-characters)
 897                (,buffer (current-buffer)))
 898            (unwind-protect
 899                (let (default-enable-multibyte-characters)
 900                  (set-buffer-multibyte nil)
 901                  ,@forms)
 902              (set-buffer ,buffer)
 903              (set-buffer-multibyte ,multibyte)))
 904        (let (default-enable-multibyte-characters)
 905          ,@forms))))
 906 (put 'mm-with-unibyte-current-buffer 'lisp-indent-function 0)
 907 (put 'mm-with-unibyte-current-buffer 'edebug-form-spec '(body))
 908
 909 (defmacro mm-with-unibyte (&rest forms)
 910   "Eval the FORMS with the default value of `enable-multibyte-characters' nil."
 911   `(let (default-enable-multibyte-characters)
 912      ,@forms))
 913 (put 'mm-with-unibyte 'lisp-indent-function 0)
 914 (put 'mm-with-unibyte 'edebug-form-spec '(body))
 915
 916 (defmacro mm-with-multibyte (&rest forms)
 917   "Eval the FORMS with the default value of `enable-multibyte-characters' t."
 918   `(let ((default-enable-multibyte-characters t))
 919      ,@forms))
 920 (put 'mm-with-multibyte 'lisp-indent-function 0)
 921 (put 'mm-with-multibyte 'edebug-form-spec '(body))
 922
 923 (defun mm-find-charset-region (b e)
 924   "Return a list of Emacs charsets in the region B to E."
 925   (cond
 926    ((and (mm-multibyte-p)
 927          (fboundp 'find-charset-region))
 928     ;; Remove composition since the base charsets have been included.
 929     ;; Remove eight-bit-*, treat them as ascii.
 930     (let ((css (find-charset-region b e)))
 931       (mapcar (lambda (cs) (setq css (delq cs css)))
 932               '(composition eight-bit-control eight-bit-graphic
 933                             control-1))
 934       css))
 935    (t
 936     ;; We are in a unibyte buffer or XEmacs non-mule, so we futz around a bit.
 937     (save-excursion
 938       (save-restriction
 939         (narrow-to-region b e)
 940         (goto-char (point-min))
 941         (skip-chars-forward "\0-\177")
 942         (if (eobp)
 943             '(ascii)
 944           (let (charset)
 945             (setq charset
 946                   (and (boundp 'current-language-environment)
 947                        (car (last (assq 'charset
 948                                         (assoc current-language-environment
 949                                                language-info-alist))))))
 950             (if (eq charset 'ascii) (setq charset nil))
 951             (or charset
 952                 (setq charset
 953                       (car (last (assq mail-parse-charset
 954                                        mm-mime-mule-charset-alist)))))
 955             (list 'ascii (or charset 'latin-iso8859-1)))))))))
 956
 957 (defun mm-auto-mode-alist ()
 958   "Return an `auto-mode-alist' with only the .gz (etc) thingies."
 959   (let ((alist auto-mode-alist)
 960         out)
 961     (while alist
 962       (when (listp (cdar alist))
 963         (push (car alist) out))
 964       (pop alist))
 965     (nreverse out)))
 966
 967 (defvar mm-inhibit-file-name-handlers
 968   '(jka-compr-handler image-file-handler)
 969   "A list of handlers doing (un)compression (etc) thingies.")
 970
 971 (defun mm-insert-file-contents (filename &optional visit beg end replace
 972                                          inhibit)
 973   "Like `insert-file-contents', but only reads in the file.
 974 A buffer may be modified in several ways after reading into the buffer due
 975 to advanced Emacs features, such as file-name-handlers, format decoding,
 976 `find-file-hooks', etc.
 977 If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'.
 978   This function ensures that none of these modifications will take place."
 979   (let* ((format-alist nil)
 980          (auto-mode-alist (if inhibit nil (mm-auto-mode-alist)))
 981          (default-major-mode 'fundamental-mode)
 982          (enable-local-variables nil)
 983          (after-insert-file-functions nil)
 984          (enable-local-eval nil)
 985          (inhibit-file-name-operation (if inhibit
 986                                           'insert-file-contents
 987                                         inhibit-file-name-operation))
 988          (inhibit-file-name-handlers
 989           (if inhibit
 990               (append mm-inhibit-file-name-handlers
 991                       inhibit-file-name-handlers)
 992             inhibit-file-name-handlers))
 993          (ffh (if (boundp 'find-file-hook)
 994                   'find-file-hook
 995                 'find-file-hooks))
 996          (val (symbol-value ffh)))
 997     (set ffh nil)
 998     (unwind-protect
 999         (insert-file-contents filename visit beg end replace)
1000       (set ffh val))))
1001
1002 (defun mm-append-to-file (start end filename &optional codesys inhibit)
1003   "Append the contents of the region to the end of file FILENAME.
1004 When called from a function, expects three arguments,
1005 START, END and FILENAME.  START and END are buffer positions
1006 saying what text to write.
1007 Optional fourth argument specifies the coding system to use when
1008 encoding the file.
1009 If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'."
1010   (let ((coding-system-for-write
1011          (or codesys mm-text-coding-system-for-write
1012              mm-text-coding-system))
1013         (inhibit-file-name-operation (if inhibit
1014                                          'append-to-file
1015                                        inhibit-file-name-operation))
1016         (inhibit-file-name-handlers
1017          (if inhibit
1018              (append mm-inhibit-file-name-handlers
1019                      inhibit-file-name-handlers)
1020            inhibit-file-name-handlers)))
1021     (write-region start end filename t 'no-message)
1022     (message "Appended to %s" filename)))
1023
1024 (defun mm-write-region (start end filename &optional append visit lockname
1025                               coding-system inhibit)
1026
1027   "Like `write-region'.
1028 If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'."
1029   (let ((coding-system-for-write
1030          (or coding-system mm-text-coding-system-for-write
1031              mm-text-coding-system))
1032         (inhibit-file-name-operation (if inhibit
1033                                          'write-region
1034                                        inhibit-file-name-operation))
1035         (inhibit-file-name-handlers
1036          (if inhibit
1037              (append mm-inhibit-file-name-handlers
1038                      inhibit-file-name-handlers)
1039            inhibit-file-name-handlers)))
1040     (write-region start end filename append visit lockname)))
1041
1042 (defun mm-image-load-path (&optional package)
1043   (let (dir result)
1044     (dolist (path load-path (nreverse result))
1045       (when (and path
1046                  (file-directory-p
1047                   (setq dir (concat (file-name-directory
1048                                      (directory-file-name path))
1049                                     "etc/images/" (or package "gnus/")))))
1050         (push dir result))
1051       (push path result))))
1052
1053 ;; Fixme: This doesn't look useful where it's used.
1054 (if (fboundp 'detect-coding-region)
1055     (defun mm-detect-coding-region (start end)
1056       "Like `detect-coding-region' except returning the best one."
1057       (let ((coding-systems
1058              (detect-coding-region start end)))
1059         (or (car-safe coding-systems)
1060             coding-systems)))
1061   (defun mm-detect-coding-region (start end)
1062     (let ((point (point)))
1063       (goto-char start)
1064       (skip-chars-forward "\0-\177" end)
1065       (prog1
1066           (if (eq (point) end) 'ascii (mm-guess-charset))
1067         (goto-char point)))))
1068
1069 (if (fboundp 'coding-system-get)
1070     (defun mm-detect-mime-charset-region (start end)
1071       "Detect MIME charset of the text in the region between START and END."
1072       (let ((cs (mm-detect-coding-region start end)))
1073         (or (coding-system-get cs :mime-charset)
1074             (coding-system-get cs 'mime-charset))))
1075   (defun mm-detect-mime-charset-region (start end)
1076     "Detect MIME charset of the text in the region between START and END."
1077     (let ((cs (mm-detect-coding-region start end)))
1078       cs)))
1079
1080 (eval-when-compile
1081   (unless (fboundp 'coding-system-to-mime-charset)
1082     (defalias 'coding-system-to-mime-charset 'ignore)))
1083
1084 (defun mm-coding-system-to-mime-charset (coding-system)
1085   "Return the MIME charset corresponding to CODING-SYSTEM.
1086 To make this function work with XEmacs, the APEL package is required."
1087   (when coding-system
1088     (or (and (fboundp 'coding-system-get)
1089              (or (coding-system-get coding-system :mime-charset)
1090                  (coding-system-get coding-system 'mime-charset)))
1091         (and (featurep 'xemacs)
1092              (or (and (fboundp 'coding-system-to-mime-charset)
1093                       (not (eq (symbol-function 'coding-system-to-mime-charset)
1094                                'ignore)))
1095                  (and (condition-case nil
1096                           (require 'mcharset)
1097                         (error nil))
1098                       (fboundp 'coding-system-to-mime-charset)))
1099              (coding-system-to-mime-charset coding-system)))))
1100
1101 (eval-when-compile
1102   (require 'jka-compr))
1103
1104 (defun mm-decompress-buffer (filename &optional inplace force)
1105   "Decompress buffer's contents, depending on jka-compr.
1106 Only when FORCE is t or `auto-compression-mode' is enabled and FILENAME
1107 agrees with `jka-compr-compression-info-list', decompression is done.
1108 Signal an error if FORCE is neither nil nor t and compressed data are
1109 not decompressed because `auto-compression-mode' is disabled.
1110 If INPLACE is nil, return decompressed data or nil without modifying
1111 the buffer.  Otherwise, replace the buffer's contents with the
1112 decompressed data.  The buffer's multibyteness must be turned off."
1113   (when (and filename
1114              (if force
1115                  (prog1 t (require 'jka-compr))
1116                (and (fboundp 'jka-compr-installed-p)
1117                     (jka-compr-installed-p))))
1118     (let ((info (jka-compr-get-compression-info filename)))
1119       (when info
1120         (unless (or (memq force (list nil t))
1121                     (jka-compr-installed-p))
1122           (error ""))
1123         (let ((prog (jka-compr-info-uncompress-program info))
1124               (args (jka-compr-info-uncompress-args info))
1125               (msg (format "%s %s..."
1126                            (jka-compr-info-uncompress-message info)
1127                            filename))
1128               (err-file (jka-compr-make-temp-name))
1129               (cur (current-buffer))
1130               (coding-system-for-read mm-binary-coding-system)
1131               (coding-system-for-write mm-binary-coding-system)
1132               retval err-msg)
1133           (message "%s" msg)
1134           (with-temp-buffer
1135             (insert-buffer-substring cur)
1136             (condition-case err
1137                 (progn
1138                   (unless (memq (apply 'call-process-region
1139                                        (point-min) (point-max)
1140                                        prog t (list t err-file) nil args)
1141                                 jka-compr-acceptable-retval-list)
1142                     (erase-buffer)
1143                     (insert (mapconcat
1144                              'identity
1145                              (delete "" (split-string
1146                                          (prog2
1147                                              (insert-file-contents err-file)
1148                                              (buffer-string)
1149                                            (erase-buffer))))
1150                              " ")
1151                             "\n")
1152                     (setq err-msg
1153                           (format "Error while executing \"%s %s < %s\""
1154                                   prog (mapconcat 'identity args " ")
1155                                   filename)))
1156                   (setq retval (buffer-string)))
1157               (error
1158                (setq err-msg (error-message-string err)))))
1159           (when (file-exists-p err-file)
1160             (ignore-errors (jka-compr-delete-temp-file err-file)))
1161           (when inplace
1162             (unless err-msg
1163               (delete-region (point-min) (point-max))
1164               (insert retval))
1165             (setq retval nil))
1166           (message "%s" (or err-msg (concat msg "done")))
1167           retval)))))
1168
1169 (eval-when-compile
1170   (unless (fboundp 'coding-system-name)
1171     (defalias 'coding-system-name 'ignore))
1172   (unless (fboundp 'find-file-coding-system-for-read-from-filename)
1173     (defalias 'find-file-coding-system-for-read-from-filename 'ignore))
1174   (unless (fboundp 'find-operation-coding-system)
1175     (defalias 'find-operation-coding-system 'ignore)))
1176
1177 (defun mm-find-buffer-file-coding-system (&optional filename)
1178   "Find coding system used to decode the contents of the current buffer.
1179 This function looks for the coding system magic cookie or examines the
1180 coding system specified by `file-coding-system-alist' being associated
1181 with FILENAME which defaults to `buffer-file-name'.  Data compressed by
1182 gzip, bzip2, etc. are allowed."
1183   (unless filename
1184     (setq filename buffer-file-name))
1185   (save-excursion
1186     (let ((decomp (unless ;; No worth to examine charset of tar files.
1187                       (and filename
1188                            (string-match
1189                             "\\.\\(?:tar\\.[^.]+\\|tbz\\|tgz\\)\\'"
1190                             filename))
1191                     (mm-decompress-buffer filename nil t))))
1192       (when decomp
1193         (set-buffer (let (default-enable-multibyte-characters)
1194                       (generate-new-buffer " *temp*")))
1195         (insert decomp)
1196         (setq filename (file-name-sans-extension filename)))
1197       (goto-char (point-min))
1198       (prog1
1199           (cond
1200            ((boundp 'set-auto-coding-function) ;; Emacs
1201             (if filename
1202                 (or (funcall (symbol-value 'set-auto-coding-function)
1203                              filename (- (point-max) (point-min)))
1204                     (car (find-operation-coding-system 'insert-file-contents
1205                                                        filename)))
1206               (let (auto-coding-alist)
1207                 (condition-case nil
1208                     (funcall (symbol-value 'set-auto-coding-function)
1209                              nil (- (point-max) (point-min)))
1210                   (error nil)))))
1211            ((featurep 'file-coding) ;; XEmacs
1212             (let ((case-fold-search t)
1213                   (end (point-at-eol))
1214                   codesys start)
1215               (or
1216                (and (re-search-forward "-\\*-+[\t ]*" end t)
1217                     (progn
1218                       (setq start (match-end 0))
1219                       (re-search-forward "[\t ]*-+\\*-" end t))
1220                     (progn
1221                       (setq end (match-beginning 0))
1222                       (goto-char start)
1223                       (or (looking-at "coding:[\t ]*\\([^\t ;]+\\)")
1224                           (re-search-forward
1225                            "[\t ;]+coding:[\t ]*\\([^\t ;]+\\)"
1226                            end t)))
1227                     (find-coding-system (setq codesys
1228                                               (intern (match-string 1))))
1229                     codesys)
1230                (and (re-search-forward "^[\t ]*;+[\t ]*Local[\t ]+Variables:"
1231                                        nil t)
1232                     (progn
1233                       (setq start (match-end 0))
1234                       (re-search-forward "^[\t ]*;+[\t ]*End:" nil t))
1235                     (progn
1236                       (setq end (match-beginning 0))
1237                       (goto-char start)
1238                       (re-search-forward
1239                        "^[\t ]*;+[\t ]*coding:[\t ]*\\([^\t\n\r ]+\\)"
1240                        end t))
1241                     (find-coding-system (setq codesys
1242                                               (intern (match-string 1))))
1243                     codesys)
1244                (and (progn
1245                       (goto-char (point-min))
1246                       (setq case-fold-search nil)
1247                       (re-search-forward "^;;;coding system: "
1248                                          ;;(+ (point-min) 3000) t))
1249                                          nil t))
1250                     (looking-at "[^\t\n\r ]+")
1251                     (find-coding-system
1252                      (setq codesys (intern (match-string 0))))
1253                     codesys)
1254                (and filename
1255                     (setq codesys
1256                           (find-file-coding-system-for-read-from-filename
1257                            filename))
1258                     (coding-system-name (coding-system-base codesys)))))))
1259         (when decomp
1260           (kill-buffer (current-buffer)))))))
1261
1262 (provide 'mm-util)
1263
1264 ;; arch-tag: 94dc5388-825d-4fd1-bfa5-2100aa351238
1265 ;;; mm-util.el ends here