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