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