code.delx.au - gnu-emacs/blob - lisp/gnus/mm-util.el

   1 ;;; mm-util.el --- Utility functions for Mule and low level things
   2
   3 ;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;;; Code:
  25
  26 (eval-when-compile (require 'cl))
  27 (require 'mail-prsvr)
  28 (require 'timer)
  29
  30 (defvar mm-mime-mule-charset-alist)
  31
  32 (defun mm-ucs-to-char (codepoint)
  33   "Convert Unicode codepoint to character."
  34   (or (decode-char 'ucs codepoint) ?#))
  35
  36 (defvar mm-coding-system-list nil)
  37 (defun mm-get-coding-system-list ()
  38   "Get the coding system list."
  39   (or mm-coding-system-list
  40       (setq mm-coding-system-list (coding-system-list))))
  41
  42 (defun mm-coding-system-p (cs)
  43   "Return CS if CS is a coding system."
  44   (and (coding-system-p cs)
  45        cs))
  46
  47 (defvar mm-charset-synonym-alist
  48   `(
  49     ;; Not in XEmacs, but it's not a proper MIME charset anyhow.
  50     ,@(unless (mm-coding-system-p 'x-ctext)
  51         '((x-ctext . ctext)))
  52     ;; ISO-8859-15 is very similar to ISO-8859-1.  But it's _different_ in 8
  53     ;; positions!
  54     ,@(unless (mm-coding-system-p 'iso-8859-15)
  55         '((iso-8859-15 . iso-8859-1)))
  56     ;; BIG-5HKSCS is similar to, but different than, BIG-5.
  57     ,@(unless (mm-coding-system-p 'big5-hkscs)
  58         '((big5-hkscs . big5)))
  59     ;; A Microsoft misunderstanding.
  60     ,@(when (and (not (mm-coding-system-p 'unicode))
  61                  (mm-coding-system-p 'utf-16-le))
  62         '((unicode . utf-16-le)))
  63     ;; A Microsoft misunderstanding.
  64     ,@(unless (mm-coding-system-p 'ks_c_5601-1987)
  65         (if (mm-coding-system-p 'cp949)
  66             '((ks_c_5601-1987 . cp949))
  67           '((ks_c_5601-1987 . euc-kr))))
  68     ;; Windows-31J is Windows Codepage 932.
  69     ,@(when (and (not (mm-coding-system-p 'windows-31j))
  70                  (mm-coding-system-p 'cp932))
  71         '((windows-31j . cp932)))
  72     ;; Charset name: GBK, Charset aliases: CP936, MS936, windows-936
  73     ;; http://www.iana.org/assignments/charset-reg/GBK
  74     ;; Emacs 22.1 has cp936, but not gbk, so we alias it:
  75     ,@(when (and (not (mm-coding-system-p 'gbk))
  76                  (mm-coding-system-p 'cp936))
  77         '((gbk . cp936)))
  78     ;; UTF8 is a bogus name for UTF-8
  79     ,@(when (and (not (mm-coding-system-p 'utf8))
  80                  (mm-coding-system-p 'utf-8))
  81         '((utf8 . utf-8)))
  82     ;; ISO8859-1 is a bogus name for ISO-8859-1
  83     ,@(when (and (not (mm-coding-system-p 'iso8859-1))
  84                  (mm-coding-system-p 'iso-8859-1))
  85         '((iso8859-1 . iso-8859-1)))
  86     ;; ISO_8859-1 is a bogus name for ISO-8859-1
  87     ,@(when (and (not (mm-coding-system-p 'iso_8859-1))
  88                  (mm-coding-system-p 'iso-8859-1))
  89         '((iso_8859-1 . iso-8859-1)))
  90     )
  91   "A mapping from unknown or invalid charset names to the real charset names.")
  92
  93 ;; Note: this has to be defined before `mm-charset-to-coding-system'.
  94 (defcustom mm-charset-eval-alist nil
  95   "An alist of (CHARSET . FORM) pairs.
  96 If an article is encoded in an unknown CHARSET, FORM is
  97 evaluated.  This allows the loading of additional libraries
  98 providing charsets on demand.  If supported by your Emacs
  99 version, you could use `autoload-coding-system' here."
 100   :version "22.1" ;; Gnus 5.10.9
 101   :type '(list (repeat :inline t
 102                        :tag "Other options"
 103                        (cons (symbol :tag "charset")
 104                              (symbol :tag "form"))))
 105   :group 'mime)
 106 (put 'mm-charset-eval-alist 'risky-local-variable t)
 107
 108 (defvar mm-charset-override-alist)
 109
 110 ;; Note: this function has to be defined before `mm-charset-override-alist'
 111 ;; since it will use this function in order to determine its default value
 112 ;; when loading mm-util.elc.
 113 (defun mm-charset-to-coding-system (charset &optional lbt
 114                                             allow-override silent)
 115   "Return coding-system corresponding to CHARSET.
 116 CHARSET is a symbol naming a MIME charset.
 117 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
 118 used as the line break code type of the coding system.
 119
 120 If ALLOW-OVERRIDE is given, use `mm-charset-override-alist' to
 121 map undesired charset names to their replacement.  This should
 122 only be used for decoding, not for encoding.
 123
 124 A non-nil value of SILENT means don't issue a warning even if CHARSET
 125 is not available."
 126   ;; OVERRIDE is used (only) in `mm-decode-body' and `mm-decode-string'.
 127   (when (stringp charset)
 128     (setq charset (intern (downcase charset))))
 129   (when lbt
 130     (setq charset (intern (format "%s-%s" charset lbt))))
 131   (cond
 132    ((null charset)
 133     charset)
 134    ;; Running in a non-MULE environment.
 135    ((or (null (mm-get-coding-system-list))
 136         (not (fboundp 'coding-system-get)))
 137     charset)
 138    ;; Check override list quite early.  Should only used for decoding, not for
 139    ;; encoding!
 140    ((and allow-override
 141          (let ((cs (cdr (assq charset mm-charset-override-alist))))
 142            (and cs (mm-coding-system-p cs) cs))))
 143    ;; ascii
 144    ((or (eq charset 'us-ascii)
 145         (string-match "ansi.x3.4" (symbol-name charset)))
 146     'ascii)
 147    ;; Check to see whether we can handle this charset.  (This depends
 148    ;; on there being some coding system matching each `mime-charset'
 149    ;; property defined, as there should be.)
 150    ((and (mm-coding-system-p charset)
 151 ;;; Doing this would potentially weed out incorrect charsets.
 152 ;;;      charset
 153 ;;;      (eq charset (coding-system-get charset 'mime-charset))
 154          )
 155     charset)
 156    ;; Use coding system Emacs knows.
 157    ((and (fboundp 'coding-system-from-name)
 158          (coding-system-from-name charset)))
 159    ;; Eval expressions from `mm-charset-eval-alist'
 160    ((let* ((el (assq charset mm-charset-eval-alist))
 161            (cs (car el))
 162            (form (cdr el)))
 163       (and cs
 164            form
 165            (prog2
 166                ;; Avoid errors...
 167                (condition-case nil (eval form) (error nil))
 168                ;; (message "Failed to eval `%s'" form))
 169                (mm-coding-system-p cs)
 170              (message "Added charset `%s' via `mm-charset-eval-alist'" cs))
 171            cs)))
 172    ;; Translate invalid charsets.
 173    ((let ((cs (cdr (assq charset mm-charset-synonym-alist))))
 174       (and cs
 175            (mm-coding-system-p cs)
 176            ;; (message
 177            ;;  "Using synonym `%s' from `mm-charset-synonym-alist' for `%s'"
 178            ;;  cs charset)
 179            cs)))
 180    ;; Last resort: search the coding system list for entries which
 181    ;; have the right mime-charset in case the canonical name isn't
 182    ;; defined (though it should be).
 183    ((let (cs)
 184       ;; mm-get-coding-system-list returns a list of cs without lbt.
 185       ;; Do we need -lbt?
 186       (dolist (c (mm-get-coding-system-list))
 187         (if (and (null cs)
 188                  (eq charset (or (coding-system-get c :mime-charset)
 189                                  (coding-system-get c 'mime-charset))))
 190             (setq cs c)))
 191       (unless (or silent cs)
 192         ;; Warn the user about unknown charset:
 193         (if (fboundp 'gnus-message)
 194             (gnus-message 7 "Unknown charset: %s" charset)
 195           (message "Unknown charset: %s" charset)))
 196       cs))))
 197
 198 ;; Note: `mm-charset-to-coding-system' has to be defined before this.
 199 (defcustom mm-charset-override-alist
 200   ;; Note: pairs that cannot be used in the Emacs version currently running
 201   ;; will be removed.
 202   '((gb2312 . gbk)
 203     (iso-8859-1 . windows-1252)
 204     (iso-8859-8 . windows-1255)
 205     (iso-8859-9 . windows-1254))
 206   "A mapping from undesired charset names to their replacement.
 207
 208 You may add pairs like (iso-8859-1 . windows-1252) here,
 209 i.e. treat iso-8859-1 as windows-1252.  windows-1252 is a
 210 superset of iso-8859-1."
 211   :type
 212   '(list
 213     :convert-widget
 214     (lambda (widget)
 215       (let ((defaults
 216               (delq nil
 217                     (mapcar (lambda (pair)
 218                               (if (mm-charset-to-coding-system (cdr pair)
 219                                                                nil nil t)
 220                                   pair))
 221                             '((gb2312 . gbk)
 222                               (iso-8859-1 . windows-1252)
 223                               (iso-8859-8 . windows-1255)
 224                               (iso-8859-9 . windows-1254)
 225                               (undecided  . windows-1252)))))
 226             (val (copy-sequence (default-value 'mm-charset-override-alist)))
 227             pair rest)
 228         (while val
 229           (push (if (and (prog1
 230                              (setq pair (assq (caar val) defaults))
 231                            (setq defaults (delq pair defaults)))
 232                          (equal (car val) pair))
 233                     `(const ,pair)
 234                   `(cons :format "%v"
 235                          (const :format "(%v" ,(caar val))
 236                          (symbol :size 3 :format " . %v)\n" ,(cdar val))))
 237                 rest)
 238           (setq val (cdr val)))
 239         (while defaults
 240           (push `(const ,(pop defaults)) rest))
 241         (widget-convert
 242          'list
 243          `(set :inline t :format "%v" ,@(nreverse rest))
 244          `(repeat :inline t :tag "Other options"
 245                   (cons :format "%v"
 246                         (symbol :size 3 :format "(%v")
 247                         (symbol :size 3 :format " . %v)\n")))))))
 248   ;; Remove pairs that cannot be used in the Emacs version currently
 249   ;; running.  Note that this section will be evaluated when loading
 250   ;; mm-util.elc.
 251   :set (lambda (symbol value)
 252          (custom-set-default
 253           symbol (delq nil
 254                        (mapcar (lambda (pair)
 255                                  (if (mm-charset-to-coding-system (cdr pair)
 256                                                                   nil nil t)
 257                                      pair))
 258                                value))))
 259   :version "22.1" ;; Gnus 5.10.9
 260   :group 'mime)
 261
 262 (defvar mm-binary-coding-system
 263   (cond
 264    ((mm-coding-system-p 'binary) 'binary)
 265    ((mm-coding-system-p 'no-conversion) 'no-conversion)
 266    (t nil))
 267   "100% binary coding system.")
 268
 269 (defvar mm-text-coding-system
 270   (or (if (memq system-type '(windows-nt ms-dos))
 271           (and (mm-coding-system-p 'raw-text-dos) 'raw-text-dos)
 272         (and (mm-coding-system-p 'raw-text) 'raw-text))
 273       mm-binary-coding-system)
 274   "Text-safe coding system (For removing ^M).")
 275
 276 (defvar mm-text-coding-system-for-write nil
 277   "Text coding system for write.")
 278
 279 (defvar mm-auto-save-coding-system
 280   (cond
 281    ((mm-coding-system-p 'utf-8-emacs)   ; Mule 7
 282     (if (memq system-type '(windows-nt ms-dos))
 283         (if (mm-coding-system-p 'utf-8-emacs-dos)
 284             'utf-8-emacs-dos mm-binary-coding-system)
 285       'utf-8-emacs))
 286    ((mm-coding-system-p 'emacs-mule)
 287     (if (memq system-type '(windows-nt ms-dos))
 288         (if (mm-coding-system-p 'emacs-mule-dos)
 289             'emacs-mule-dos mm-binary-coding-system)
 290       'emacs-mule))
 291    ((mm-coding-system-p 'escape-quoted) 'escape-quoted)
 292    (t mm-binary-coding-system))
 293   "Coding system of auto save file.")
 294
 295 (defvar mm-universal-coding-system mm-auto-save-coding-system
 296   "The universal coding system.")
 297
 298 ;; Fixme: some of the cars here aren't valid MIME charsets.  That
 299 ;; should only matter with XEmacs, though.
 300 (defvar mm-mime-mule-charset-alist
 301   '((us-ascii ascii)
 302     (iso-8859-1 latin-iso8859-1)
 303     (iso-8859-2 latin-iso8859-2)
 304     (iso-8859-3 latin-iso8859-3)
 305     (iso-8859-4 latin-iso8859-4)
 306     (iso-8859-5 cyrillic-iso8859-5)
 307     ;; Non-mule (X)Emacs uses the last mule-charset for 8bit characters.
 308     ;; The fake mule-charset, gnus-koi8-r, tells Gnus that the default
 309     ;; charset is koi8-r, not iso-8859-5.
 310     (koi8-r cyrillic-iso8859-5 gnus-koi8-r)
 311     (iso-8859-6 arabic-iso8859-6)
 312     (iso-8859-7 greek-iso8859-7)
 313     (iso-8859-8 hebrew-iso8859-8)
 314     (iso-8859-9 latin-iso8859-9)
 315     (iso-8859-14 latin-iso8859-14)
 316     (iso-8859-15 latin-iso8859-15)
 317     (viscii vietnamese-viscii-lower)
 318     (iso-2022-jp latin-jisx0201 japanese-jisx0208 japanese-jisx0208-1978)
 319     (euc-kr korean-ksc5601)
 320     (gb2312 chinese-gb2312)
 321     (gbk chinese-gbk)
 322     (gb18030 gb18030-2-byte
 323              gb18030-4-byte-bmp gb18030-4-byte-smp
 324              gb18030-4-byte-ext-1 gb18030-4-byte-ext-2)
 325     (big5 chinese-big5-1 chinese-big5-2)
 326     (tibetan tibetan)
 327     (thai-tis620 thai-tis620)
 328     (windows-1251 cyrillic-iso8859-5)
 329     (iso-2022-7bit ethiopic arabic-1-column arabic-2-column)
 330     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
 331                    latin-jisx0201 japanese-jisx0208-1978
 332                    chinese-gb2312 japanese-jisx0208
 333                    korean-ksc5601 japanese-jisx0212)
 334     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
 335                     latin-jisx0201 japanese-jisx0208-1978
 336                     chinese-gb2312 japanese-jisx0208
 337                     korean-ksc5601 japanese-jisx0212
 338                     chinese-cns11643-1 chinese-cns11643-2)
 339     (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
 340                     cyrillic-iso8859-5 greek-iso8859-7
 341                     latin-jisx0201 japanese-jisx0208-1978
 342                     chinese-gb2312 japanese-jisx0208
 343                     korean-ksc5601 japanese-jisx0212
 344                     chinese-cns11643-1 chinese-cns11643-2
 345                     chinese-cns11643-3 chinese-cns11643-4
 346                     chinese-cns11643-5 chinese-cns11643-6
 347                     chinese-cns11643-7)
 348     (iso-2022-jp-3 latin-jisx0201 japanese-jisx0208-1978 japanese-jisx0208
 349                    japanese-jisx0213-1 japanese-jisx0213-2)
 350     (shift_jis latin-jisx0201 katakana-jisx0201 japanese-jisx0208)
 351     (utf-8))
 352   "Alist of MIME-charset/MULE-charsets.")
 353
 354 ;; Correct by construction, but should be unnecessary for Emacs:
 355 (when (and (fboundp 'coding-system-list)
 356            (fboundp 'sort-coding-systems))
 357   (let ((css (sort-coding-systems (coding-system-list 'base-only)))
 358         cs mime mule alist)
 359     (while css
 360       (setq cs (pop css)
 361             mime (or (coding-system-get cs :mime-charset) ; Emacs 23 (unicode)
 362                      (coding-system-get cs 'mime-charset)))
 363       (when (and mime
 364                  (not (eq t (setq mule
 365                                   (coding-system-get cs 'safe-charsets))))
 366                  (not (assq mime alist)))
 367         (push (cons mime (delq 'ascii mule)) alist)))
 368     (setq mm-mime-mule-charset-alist (nreverse alist))))
 369
 370 (defvar mm-hack-charsets '(iso-8859-15 iso-2022-jp-2)
 371   "A list of special charsets.
 372 Valid elements include:
 373 `iso-8859-15'    convert ISO-8859-1, -9 to ISO-8859-15 if ISO-8859-15 exists.
 374 `iso-2022-jp-2'  convert ISO-2022-jp to ISO-2022-jp-2 if ISO-2022-jp-2 exists."
 375 )
 376
 377 (defvar mm-iso-8859-15-compatible
 378   '((iso-8859-1 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE")
 379     (iso-8859-9 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE\xD0\xDD\xDE\xF0\xFD\xFE"))
 380   "ISO-8859-15 exchangeable coding systems and inconvertible characters.")
 381
 382 (defvar mm-iso-8859-x-to-15-table
 383   (and (fboundp 'coding-system-p)
 384        (mm-coding-system-p 'iso-8859-15)
 385        (mapcar
 386         (lambda (cs)
 387           (if (mm-coding-system-p (car cs))
 388               (let ((c (string-to-char
 389                         (decode-coding-string "\341" (car cs)))))
 390                 (cons (char-charset c)
 391                       (cons
 392                        (- (string-to-char
 393                            (decode-coding-string "\341" 'iso-8859-15)) c)
 394                        (string-to-list (decode-coding-string (car (cdr cs))
 395                                                              (car cs))))))
 396             '(gnus-charset 0)))
 397         mm-iso-8859-15-compatible))
 398   "A table of the difference character between ISO-8859-X and ISO-8859-15.")
 399
 400 (defcustom mm-coding-system-priorities
 401   (and (string-match "\\`Japanese" current-language-environment)
 402        ;; Japanese users prefer iso-2022-jp to others usually used
 403        ;; for `buffer-file-coding-system', however iso-8859-1 should
 404        ;; be used when there are only ASCII and Latin-1 characters.
 405        '(iso-8859-1 iso-2022-jp utf-8))
 406   "Preferred coding systems for encoding outgoing messages.
 407
 408 More than one suitable coding system may be found for some text.
 409 By default, the coding system with the highest priority is used
 410 to encode outgoing messages (see `sort-coding-systems').  If this
 411 variable is set, it overrides the default priority."
 412   :version "24.4"
 413   :type '(repeat (symbol :tag "Coding system"))
 414   :group 'mime)
 415
 416 ;; ??
 417 (defvar mm-use-find-coding-systems-region t
 418   "Use `find-coding-systems-region' to find proper coding systems.
 419
 420 Setting it to nil is useful on Emacsen supporting Unicode if sending
 421 mail with multiple parts is preferred to sending a Unicode one.")
 422
 423 (defvar mm-extra-numeric-entities
 424   (mapcar
 425    (lambda (item)
 426      (cons (car item) (mm-ucs-to-char (cdr item))))
 427    '((#x80 . #x20AC) (#x82 . #x201A) (#x83 . #x0192) (#x84 . #x201E)
 428      (#x85 . #x2026) (#x86 . #x2020) (#x87 . #x2021) (#x88 . #x02C6)
 429      (#x89 . #x2030) (#x8A . #x0160) (#x8B . #x2039) (#x8C . #x0152)
 430      (#x8E . #x017D) (#x91 . #x2018) (#x92 . #x2019) (#x93 . #x201C)
 431      (#x94 . #x201D) (#x95 . #x2022) (#x96 . #x2013) (#x97 . #x2014)
 432      (#x98 . #x02DC) (#x99 . #x2122) (#x9A . #x0161) (#x9B . #x203A)
 433      (#x9C . #x0153) (#x9E . #x017E) (#x9F . #x0178)))
 434   "*Alist of extra numeric entities and characters other than ISO 10646.
 435 This table is used for decoding extra numeric entities to characters,
 436 like \"&#128;\" to the euro sign, mainly in html messages.")
 437
 438 ;;; Internal variables:
 439
 440 ;;; Functions:
 441
 442 (defun mm-mule-charset-to-mime-charset (charset)
 443   "Return the MIME charset corresponding to the given Mule CHARSET."
 444   (let ((css (sort (sort-coding-systems
 445                     (find-coding-systems-for-charsets (list charset)))
 446                    'mm-sort-coding-systems-predicate))
 447         cs mime)
 448     (while (and (not mime)
 449                 css)
 450       (when (setq cs (pop css))
 451         (setq mime (or (coding-system-get cs :mime-charset)
 452                        (coding-system-get cs 'mime-charset)))))
 453     mime))
 454
 455 (defun mm-enable-multibyte ()
 456   "Set the multibyte flag of the current buffer.
 457 Only do this if the default value of `enable-multibyte-characters' is
 458 non-nil."
 459   (set-buffer-multibyte 'to))
 460
 461 (defun mm-disable-multibyte ()
 462   "Unset the multibyte flag of in the current buffer."
 463   (set-buffer-multibyte nil))
 464
 465 (defun mm-preferred-coding-system (charset)
 466   ;; A typo in some Emacs versions.
 467   (or (get-charset-property charset 'preferred-coding-system)
 468       (get-charset-property charset 'prefered-coding-system)))
 469
 470 ;; Mule charsets shouldn't be used.
 471 (defsubst mm-guess-charset ()
 472   "Guess Mule charset from the language environment."
 473   (or
 474    mail-parse-mule-charset ;; cached mule-charset
 475    (progn
 476      (setq mail-parse-mule-charset
 477            (and (car (last
 478                       (assq 'charset
 479                             (assoc current-language-environment
 480                                    language-info-alist))))))
 481      (if (or (not mail-parse-mule-charset)
 482              (eq mail-parse-mule-charset 'ascii))
 483          (setq mail-parse-mule-charset
 484                (or (car (last (assq mail-parse-charset
 485                                     mm-mime-mule-charset-alist)))
 486                    ;; default
 487                    'latin-iso8859-1)))
 488      mail-parse-mule-charset)))
 489
 490 (defun mm-charset-after (&optional pos)
 491   "Return charset of a character in current buffer at position POS.
 492 If POS is nil, it defaults to the current point.
 493 If POS is out of range, the value is nil."
 494   (let ((char (char-after pos)) charset)
 495     (if (< char 128)
 496         (setq charset 'ascii)
 497       (setq charset (char-charset char))
 498       (if (and charset (not (memq charset '(ascii eight-bit-control
 499                                                   eight-bit-graphic))))
 500           charset
 501         (mm-guess-charset)))))
 502
 503 (defun mm-mime-charset (charset)
 504   "Return the MIME charset corresponding to the given Mule CHARSET."
 505   (when (eq charset 'unknown)
 506     (error "The message contains non-printable characters, please use attachment"))
 507   (or
 508    (and (mm-preferred-coding-system charset)
 509         (coding-system-get (mm-preferred-coding-system charset) 'mime-charset))
 510    (and (eq charset 'ascii)
 511         'us-ascii)
 512    (mm-preferred-coding-system charset)
 513    (mm-mule-charset-to-mime-charset charset)))
 514
 515 ;; Fixme:  This is used in places when it should be testing the
 516 ;; default multibyteness.
 517 (defun mm-multibyte-p ()
 518   "Non-nil if multibyte is enabled in the current buffer."
 519   enable-multibyte-characters)
 520
 521 (defun mm-iso-8859-x-to-15-region (&optional b e)
 522   (let (charset item c inconvertible)
 523     (save-restriction
 524       (if e (narrow-to-region b e))
 525       (goto-char (point-min))
 526       (skip-chars-forward "\0-\177")
 527       (while (not (eobp))
 528         (cond
 529          ((not (setq item (assq (char-charset (setq c (char-after)))
 530                                 mm-iso-8859-x-to-15-table)))
 531           (forward-char))
 532          ((memq c (cdr (cdr item)))
 533           (setq inconvertible t)
 534           (forward-char))
 535          (t
 536           (insert-before-markers (prog1 (+ c (car (cdr item)))
 537                                    (delete-char 1)))))
 538         (skip-chars-forward "\0-\177")))
 539     (not inconvertible)))
 540
 541 (defun mm-sort-coding-systems-predicate (a b)
 542   (let ((priorities
 543          (mapcar (lambda (cs)
 544                    ;; Note: invalid entries are dropped silently
 545                    (and (setq cs (mm-coding-system-p cs))
 546                         (coding-system-base cs)))
 547                  mm-coding-system-priorities)))
 548     (and (setq a (mm-coding-system-p a))
 549          (if (setq b (mm-coding-system-p b))
 550              (> (length (memq (coding-system-base a) priorities))
 551                 (length (memq (coding-system-base b) priorities)))
 552            t))))
 553
 554 (defun mm-find-mime-charset-region (b e &optional hack-charsets)
 555   "Return the MIME charsets needed to encode the region between B and E.
 556 nil means ASCII, a single-element list represents an appropriate MIME
 557 charset, and a longer list means no appropriate charset."
 558   (let (charsets)
 559     ;; The return possibilities of this function are a mess...
 560     (or (and (mm-multibyte-p)
 561              mm-use-find-coding-systems-region
 562              ;; Find the mime-charset of the most preferred coding
 563              ;; system that has one.
 564              (let ((systems (find-coding-systems-region b e)))
 565                (when mm-coding-system-priorities
 566                  (setq systems
 567                        (sort systems 'mm-sort-coding-systems-predicate)))
 568                (setq systems (delq 'compound-text systems))
 569                (unless (equal systems '(undecided))
 570                  (while systems
 571                    (let* ((head (pop systems))
 572                           (cs (or (coding-system-get head :mime-charset)
 573                                   (coding-system-get head 'mime-charset))))
 574                      ;; The mime-charset (`x-ctext') of
 575                      ;; `compound-text' is not in the IANA list.  We
 576                      ;; shouldn't normally use anything here with a
 577                      ;; mime-charset having an `x-' prefix.
 578                      ;; Fixme:  Allow this to be overridden, since
 579                      ;; there is existing use of x-ctext.
 580                      ;; Also people apparently need the coding system
 581                      ;; `iso-2022-jp-3' (which Mule-UCS defines with
 582                      ;; mime-charset, though it's not valid).
 583                      (if (and cs
 584                               (not (string-match "^[Xx]-" (symbol-name cs)))
 585                               ;; UTF-16 of any variety is invalid for
 586                               ;; text parts and, unfortunately, has
 587                               ;; mime-charset defined both in Mule-UCS
 588                               ;; and versions of Emacs.  (The name
 589                               ;; might be `mule-utf-16...'  or
 590                               ;; `utf-16...'.)
 591                               (not (string-match "utf-16" (symbol-name cs))))
 592                          (setq systems nil
 593                                charsets (list cs))))))
 594                charsets))
 595         ;; We're not multibyte, or a single coding system won't cover it.
 596         (setq charsets
 597               (delete-dups
 598                (mapcar 'mm-mime-charset
 599                        (delq 'ascii
 600                              (mm-find-charset-region b e))))))
 601     (if (and (> (length charsets) 1)
 602              (memq 'iso-8859-15 charsets)
 603              (memq 'iso-8859-15 hack-charsets)
 604              (save-excursion (mm-iso-8859-x-to-15-region b e)))
 605         (dolist (x mm-iso-8859-15-compatible)
 606           (setq charsets (delq (car x) charsets))))
 607     (if (and (memq 'iso-2022-jp-2 charsets)
 608              (memq 'iso-2022-jp-2 hack-charsets))
 609         (setq charsets (delq 'iso-2022-jp charsets)))
 610     charsets))
 611
 612 (defmacro mm-with-unibyte-buffer (&rest forms)
 613   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 614 Use unibyte mode for this."
 615   `(with-temp-buffer
 616      (mm-disable-multibyte)
 617      ,@forms))
 618 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
 619 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
 620
 621 (defmacro mm-with-multibyte-buffer (&rest forms)
 622   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 623 Use multibyte mode for this."
 624   `(with-temp-buffer
 625      (mm-enable-multibyte)
 626      ,@forms))
 627 (put 'mm-with-multibyte-buffer 'lisp-indent-function 0)
 628 (put 'mm-with-multibyte-buffer 'edebug-form-spec '(body))
 629
 630 (defmacro mm-with-unibyte-current-buffer (&rest forms)
 631   "Evaluate FORMS with current buffer temporarily made unibyte.
 632
 633 Note: We recommend not using this macro any more; there should be
 634 better ways to do a similar thing.  The previous version of this macro
 635 bound the default value of `enable-multibyte-characters' to nil while
 636 evaluating FORMS but it is no longer done.  So, some programs assuming
 637 it if any may malfunction."
 638   (declare (obsolete nil "25.1") (indent 0) (debug t))
 639   (let ((multibyte (make-symbol "multibyte")))
 640     `(let ((,multibyte enable-multibyte-characters))
 641        (when ,multibyte
 642          (set-buffer-multibyte nil))
 643        (prog1
 644            (progn ,@forms)
 645          (when ,multibyte
 646            (set-buffer-multibyte t))))))
 647
 648 (defun mm-find-charset-region (b e)
 649   "Return a list of Emacs charsets in the region B to E."
 650   (cond
 651    ((mm-multibyte-p)
 652     ;; Remove composition since the base charsets have been included.
 653     ;; Remove eight-bit-*, treat them as ascii.
 654     (let ((css (find-charset-region b e)))
 655       (dolist (cs '(composition eight-bit-control eight-bit-graphic control-1))
 656         (setq css (delq cs css)))
 657       css))
 658    (t
 659     ;; We are in a unibyte buffer, so we futz around a bit.
 660     (save-excursion
 661       (save-restriction
 662         (narrow-to-region b e)
 663         (goto-char (point-min))
 664         (skip-chars-forward "\0-\177")
 665         (if (eobp)
 666             '(ascii)
 667           (let (charset)
 668             (setq charset (car (last (assq 'charset
 669                                            (assoc current-language-environment
 670                                                   language-info-alist)))))
 671             (if (eq charset 'ascii) (setq charset nil))
 672             (or charset
 673                 (setq charset
 674                       (car (last (assq mail-parse-charset
 675                                        mm-mime-mule-charset-alist)))))
 676             (list 'ascii (or charset 'latin-iso8859-1)))))))))
 677
 678 (defun mm-auto-mode-alist ()
 679   "Return an `auto-mode-alist' with only the .gz (etc) thingies."
 680   (let ((alist auto-mode-alist)
 681         out)
 682     (while alist
 683       (when (listp (cdar alist))
 684         (push (car alist) out))
 685       (pop alist))
 686     (nreverse out)))
 687
 688 (defvar mm-inhibit-file-name-handlers
 689   '(jka-compr-handler image-file-handler epa-file-handler)
 690   "A list of handlers doing (un)compression (etc) thingies.")
 691
 692 (defun mm-insert-file-contents (filename &optional visit beg end replace
 693                                          inhibit)
 694   "Like `insert-file-contents', but only reads in the file.
 695 A buffer may be modified in several ways after reading into the buffer due
 696 to advanced Emacs features, such as file-name-handlers, format decoding,
 697 `find-file-hook', etc.
 698 If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'.
 699 This function ensures that none of these modifications will take place."
 700   (letf* ((format-alist nil)
 701           (auto-mode-alist (if inhibit nil (mm-auto-mode-alist)))
 702           ((default-value 'major-mode) 'fundamental-mode)
 703           (enable-local-variables nil)
 704           (after-insert-file-functions nil)
 705           (enable-local-eval nil)
 706           (inhibit-file-name-operation (if inhibit
 707                                            'insert-file-contents
 708                                          inhibit-file-name-operation))
 709           (inhibit-file-name-handlers
 710            (if inhibit
 711                (append mm-inhibit-file-name-handlers
 712                        inhibit-file-name-handlers)
 713              inhibit-file-name-handlers))
 714           (find-file-hook nil))
 715     (insert-file-contents filename visit beg end replace)))
 716
 717 (defun mm-append-to-file (start end filename &optional codesys inhibit)
 718   "Append the contents of the region to the end of file FILENAME.
 719 When called from a function, expects three arguments,
 720 START, END and FILENAME.  START and END are buffer positions
 721 saying what text to write.
 722 Optional fourth argument specifies the coding system to use when
 723 encoding the file.
 724 If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'."
 725   (let ((coding-system-for-write
 726          (or codesys mm-text-coding-system-for-write
 727              mm-text-coding-system))
 728         (inhibit-file-name-operation (if inhibit
 729                                          'append-to-file
 730                                        inhibit-file-name-operation))
 731         (inhibit-file-name-handlers
 732          (if inhibit
 733              (append mm-inhibit-file-name-handlers
 734                      inhibit-file-name-handlers)
 735            inhibit-file-name-handlers)))
 736     (write-region start end filename t 'no-message)
 737     (message "Appended to %s" filename)))
 738
 739 (defun mm-write-region (start end filename &optional append visit lockname
 740                               coding-system inhibit)
 741
 742   "Like `write-region'.
 743 If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'."
 744   (let ((coding-system-for-write
 745          (or coding-system mm-text-coding-system-for-write
 746              mm-text-coding-system))
 747         (inhibit-file-name-operation (if inhibit
 748                                          'write-region
 749                                        inhibit-file-name-operation))
 750         (inhibit-file-name-handlers
 751          (if inhibit
 752              (append mm-inhibit-file-name-handlers
 753                      inhibit-file-name-handlers)
 754            inhibit-file-name-handlers)))
 755     (write-region start end filename append visit lockname)))
 756
 757 (defalias 'mm-make-temp-file 'make-temp-file)
 758 (define-obsolete-function-alias 'mm-make-temp-file 'make-temp-file "25.2")
 759
 760 (defvar mm-image-load-path-cache nil)
 761
 762 (defun mm-image-load-path (&optional package)
 763   (if (and mm-image-load-path-cache
 764            (equal load-path (car mm-image-load-path-cache)))
 765       (cdr mm-image-load-path-cache)
 766     (let (dir result)
 767       (dolist (path load-path)
 768         (when (and path
 769                    (file-directory-p
 770                     (setq dir (concat (file-name-directory
 771                                        (directory-file-name path))
 772                                       "etc/images/" (or package "gnus/")))))
 773           (push dir result)))
 774       (setq result (nreverse result)
 775             mm-image-load-path-cache (cons load-path result))
 776       result)))
 777
 778 ;; Fixme: This doesn't look useful where it's used.
 779 (defun mm-detect-coding-region (start end)
 780   "Like `detect-coding-region' except returning the best one."
 781   (let ((coding-systems (detect-coding-region start end)))
 782     (or (car-safe coding-systems)
 783         coding-systems)))
 784
 785 (declare-function mm-detect-coding-region "mm-util" (start end))
 786
 787 (defun mm-detect-mime-charset-region (start end)
 788   "Detect MIME charset of the text in the region between START and END."
 789   (let ((cs (mm-detect-coding-region start end)))
 790     (coding-system-get cs 'mime-charset)))
 791
 792 (defun mm-coding-system-to-mime-charset (coding-system)
 793   "Return the MIME charset corresponding to CODING-SYSTEM."
 794   (and coding-system
 795        (coding-system-get coding-system 'mime-charset)))
 796
 797 (defvar jka-compr-acceptable-retval-list)
 798 (declare-function jka-compr-make-temp-name "jka-compr" (&optional local))
 799
 800 (defun mm-decompress-buffer (filename &optional inplace force)
 801   "Decompress buffer's contents, depending on jka-compr.
 802 Only when FORCE is t or `auto-compression-mode' is enabled and FILENAME
 803 agrees with `jka-compr-compression-info-list', decompression is done.
 804 Signal an error if FORCE is neither nil nor t and compressed data are
 805 not decompressed because `auto-compression-mode' is disabled.
 806 If INPLACE is nil, return decompressed data or nil without modifying
 807 the buffer.  Otherwise, replace the buffer's contents with the
 808 decompressed data.  The buffer's multibyteness must be turned off."
 809   (when (and filename
 810              (if force
 811                  (prog1 t (require 'jka-compr))
 812                (and (fboundp 'jka-compr-installed-p)
 813                     (jka-compr-installed-p))))
 814     (let ((info (jka-compr-get-compression-info filename)))
 815       (when info
 816         (unless (or (memq force (list nil t))
 817                     (jka-compr-installed-p))
 818           (error ""))
 819         (let ((prog (jka-compr-info-uncompress-program info))
 820               (args (jka-compr-info-uncompress-args info))
 821               (msg (format "%s %s..."
 822                            (jka-compr-info-uncompress-message info)
 823                            filename))
 824               (err-file (jka-compr-make-temp-name))
 825               (cur (current-buffer))
 826               (coding-system-for-read mm-binary-coding-system)
 827               (coding-system-for-write mm-binary-coding-system)
 828               retval err-msg)
 829           (message "%s" msg)
 830           (mm-with-unibyte-buffer
 831             (insert-buffer-substring cur)
 832             (condition-case err
 833                 (progn
 834                   (unless (memq (apply 'call-process-region
 835                                        (point-min) (point-max)
 836                                        prog t (list t err-file) nil args)
 837                                 jka-compr-acceptable-retval-list)
 838                     (erase-buffer)
 839                     (insert (mapconcat 'identity
 840                                        (split-string
 841                                         (prog2
 842                                             (insert-file-contents err-file)
 843                                             (buffer-string)
 844                                           (erase-buffer)) t)
 845                                        " ")
 846                             "\n")
 847                     (setq err-msg
 848                           (format "Error while executing \"%s %s < %s\""
 849                                   prog (mapconcat 'identity args " ")
 850                                   filename)))
 851                   (setq retval (buffer-string)))
 852               (error
 853                (setq err-msg (error-message-string err)))))
 854           (when (file-exists-p err-file)
 855             (ignore-errors (delete-file err-file)))
 856           (when inplace
 857             (unless err-msg
 858               (delete-region (point-min) (point-max))
 859               (insert retval))
 860             (setq retval nil))
 861           (message "%s" (or err-msg (concat msg "done")))
 862           retval)))))
 863
 864 (defun mm-find-buffer-file-coding-system (&optional filename)
 865   "Find coding system used to decode the contents of the current buffer.
 866 This function looks for the coding system magic cookie or examines the
 867 coding system specified by `file-coding-system-alist' being associated
 868 with FILENAME which defaults to `buffer-file-name'.  Data compressed by
 869 gzip, bzip2, etc. are allowed."
 870   (unless filename
 871     (setq filename buffer-file-name))
 872   (save-excursion
 873     (let ((decomp (unless ;; Not worth it to examine charset of tar files.
 874                       (and filename
 875                            (string-match
 876                             "\\.\\(?:tar\\.[^.]+\\|tbz\\|tgz\\)\\'"
 877                             filename))
 878                     (mm-decompress-buffer filename nil t))))
 879       (when decomp
 880         (set-buffer (generate-new-buffer " *temp*"))
 881         (mm-disable-multibyte)
 882         (insert decomp)
 883         (setq filename (file-name-sans-extension filename)))
 884       (goto-char (point-min))
 885       (unwind-protect
 886           (if filename
 887               (or (funcall (symbol-value 'set-auto-coding-function)
 888                            filename (- (point-max) (point-min)))
 889                   (car (find-operation-coding-system 'insert-file-contents
 890                                                      filename)))
 891             (let (auto-coding-alist)
 892               (condition-case nil
 893                   (funcall (symbol-value 'set-auto-coding-function)
 894                            nil (- (point-max) (point-min)))
 895                 (error nil))))
 896         (when decomp
 897           (kill-buffer (current-buffer)))))))
 898
 899 (provide 'mm-util)
 900
 901 ;;; mm-util.el ends here