cgit.sxemacs.org Git - gnus/blob - lisp/mm-util.el

   1 ;;; mm-util.el --- Utility functions for Mule and low level things
   2
   3 ;; Copyright (C) 1998-2011  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 ;; For Emacs <22.2 and XEmacs.
  27 (eval-and-compile
  28   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
  29
  30 (eval-when-compile (require 'cl))
  31 (require 'mail-prsvr)
  32
  33 (eval-and-compile
  34   (if (featurep 'xemacs)
  35       (unless (ignore-errors
  36                 (require 'timer-funcs))
  37         (require 'timer))
  38     (require 'timer)))
  39
  40 (defvar mm-mime-mule-charset-alist )
  41 ;; Note this is not presently used on Emacs >= 23, which is good,
  42 ;; since it means standalone message-mode (which requires mml and
  43 ;; hence mml-util) does not load gnus-util.
  44 (autoload 'gnus-completing-read "gnus-util")
  45
  46 ;; Emulate functions that are not available in every (X)Emacs version.
  47 ;; The name of a function is prefixed with mm-, like `mm-char-int' for
  48 ;; `char-int' that is a native XEmacs function, not available in Emacs.
  49 ;; Gnus programs all should use mm- functions, not the original ones.
  50 (eval-and-compile
  51   (mapc
  52    (lambda (elem)
  53      (let ((nfunc (intern (format "mm-%s" (car elem)))))
  54        (if (fboundp (car elem))
  55            (defalias nfunc (car elem))
  56          (defalias nfunc (cdr elem)))))
  57    `(;; `coding-system-list' is not available in XEmacs 21.4 built
  58      ;; without the `file-coding' feature.
  59      (coding-system-list . ignore)
  60      ;; `char-int' is an XEmacs function, not available in Emacs.
  61      (char-int . identity)
  62      ;; `coding-system-equal' is an Emacs function, not available in XEmacs.
  63      (coding-system-equal . equal)
  64      ;; `annotationp' is an XEmacs function, not available in Emacs.
  65      (annotationp . ignore)
  66      ;; `set-buffer-file-coding-system' is not available in XEmacs 21.4
  67      ;; built without the `file-coding' feature.
  68      (set-buffer-file-coding-system . ignore)
  69      ;; `read-charset' is an Emacs function, not available in XEmacs.
  70      (read-charset
  71       . ,(lambda (prompt)
  72            "Return a charset."
  73            (intern
  74             (gnus-completing-read
  75              prompt
  76              (mapcar (lambda (e) (symbol-name (car e)))
  77                      mm-mime-mule-charset-alist)
  78              t))))
  79      ;; `subst-char-in-string' is not available in XEmacs 21.4.
  80      (subst-char-in-string
  81       . ,(lambda (from to string &optional inplace)
  82            ;; stolen (and renamed) from nnheader.el
  83            "Replace characters in STRING from FROM to TO.
  84           Unless optional argument INPLACE is non-nil, return a new string."
  85            (let ((string (if inplace string (copy-sequence string)))
  86                  (len (length string))
  87                  (idx 0))
  88              ;; Replace all occurrences of FROM with TO.
  89              (while (< idx len)
  90                (when (= (aref string idx) from)
  91                  (aset string idx to))
  92                (setq idx (1+ idx)))
  93              string)))
  94      ;; `replace-in-string' is an XEmacs function, not available in Emacs.
  95      (replace-in-string
  96       . ,(lambda (string regexp rep &optional literal)
  97            "See `replace-regexp-in-string', only the order of args differs."
  98            (replace-regexp-in-string regexp rep string nil literal)))
  99      ;; `string-as-unibyte' is an Emacs function, not available in XEmacs.
 100      (string-as-unibyte . identity)
 101      ;; `string-make-unibyte' is an Emacs function, not available in XEmacs.
 102      (string-make-unibyte . identity)
 103      ;; string-as-multibyte often doesn't really do what you think it does.
 104      ;; Example:
 105      ;;    (aref (string-as-multibyte "\201") 0) -> 129 (aka ?\201)
 106      ;;    (aref (string-as-multibyte "\300") 0) -> 192 (aka ?\300)
 107      ;;    (aref (string-as-multibyte "\300\201") 0) -> 192 (aka ?\300)
 108      ;;    (aref (string-as-multibyte "\300\201") 1) -> 129 (aka ?\201)
 109      ;; but
 110      ;;    (aref (string-as-multibyte "\201\300") 0) -> 2240
 111      ;;    (aref (string-as-multibyte "\201\300") 1) -> <error>
 112      ;; Better use string-to-multibyte or encode-coding-string.
 113      ;; If you really need string-as-multibyte somewhere it's usually
 114      ;; because you're using the internal emacs-mule representation (maybe
 115      ;; because you're using string-as-unibyte somewhere), which is
 116      ;; generally a problem in itself.
 117      ;; Here is an approximate equivalence table to help think about it:
 118      ;; (string-as-multibyte s)   ~= (decode-coding-string s 'emacs-mule)
 119      ;; (string-to-multibyte s)   ~= (decode-coding-string s 'binary)
 120      ;; (string-make-multibyte s) ~= (decode-coding-string s locale-coding-system)
 121      ;; `string-as-multibyte' is an Emacs function, not available in XEmacs.
 122      (string-as-multibyte . identity)
 123      ;; `multibyte-string-p' is an Emacs function, not available in XEmacs.
 124      (multibyte-string-p . ignore)
 125      ;; `insert-byte' is available only in Emacs 23.1 or greater.
 126      (insert-byte . insert-char)
 127      ;; `multibyte-char-to-unibyte' is an Emacs function, not available
 128      ;; in XEmacs.
 129      (multibyte-char-to-unibyte . identity)
 130      ;; `set-buffer-multibyte' is an Emacs function, not available in XEmacs.
 131      (set-buffer-multibyte . ignore)
 132      ;; `special-display-p' is an Emacs function, not available in XEmacs.
 133      (special-display-p
 134       . ,(lambda (buffer-name)
 135            "Returns non-nil if a buffer named BUFFER-NAME gets a special frame."
 136            (and special-display-function
 137                 (or (and (member buffer-name special-display-buffer-names) t)
 138                     (cdr (assoc buffer-name special-display-buffer-names))
 139                     (catch 'return
 140                       (dolist (elem special-display-regexps)
 141                         (and (stringp elem)
 142                              (string-match elem buffer-name)
 143                              (throw 'return t))
 144                         (and (consp elem)
 145                              (stringp (car elem))
 146                              (string-match (car elem) buffer-name)
 147                              (throw 'return (cdr elem)))))))))
 148      ;; `substring-no-properties' is available only in Emacs 22.1 or greater.
 149      (substring-no-properties
 150       . ,(lambda (string &optional from to)
 151            "Return a substring of STRING, without text properties.
 152 It starts at index FROM and ending before TO.
 153 TO may be nil or omitted; then the substring runs to the end of STRING.
 154 If FROM is nil or omitted, the substring starts at the beginning of STRING.
 155 If FROM or TO is negative, it counts from the end.
 156
 157 With one argument, just copy STRING without its properties."
 158            (setq string (substring string (or from 0) to))
 159            (set-text-properties 0 (length string) nil string)
 160            string))
 161      ;; `line-number-at-pos' is available only in Emacs 22.1 or greater
 162      ;; and XEmacs 21.5.
 163      (line-number-at-pos
 164       . ,(lambda (&optional pos)
 165            "Return (narrowed) buffer line number at position POS.
 166 If POS is nil, use current buffer location.
 167 Counting starts at (point-min), so the value refers
 168 to the contents of the accessible portion of the buffer."
 169            (let ((opoint (or pos (point))) start)
 170              (save-excursion
 171                (goto-char (point-min))
 172                (setq start (point))
 173                (goto-char opoint)
 174                (forward-line 0)
 175                (1+ (count-lines start (point))))))))))
 176
 177 ;; `decode-coding-string', `encode-coding-string', `decode-coding-region'
 178 ;; and `encode-coding-region' are available in Emacs and XEmacs built with
 179 ;; the `file-coding' feature, but the XEmacs versions treat nil, that is
 180 ;; given as the `coding-system' argument, as the `binary' coding system.
 181 (eval-and-compile
 182   (if (featurep 'xemacs)
 183       (if (featurep 'file-coding)
 184           (progn
 185             (defun mm-decode-coding-string (str coding-system)
 186               (if coding-system
 187                   (decode-coding-string str coding-system)
 188                 str))
 189             (defun mm-encode-coding-string (str coding-system)
 190               (if coding-system
 191                   (encode-coding-string str coding-system)
 192                 str))
 193             (defun mm-decode-coding-region (start end coding-system)
 194               (if coding-system
 195                   (decode-coding-region start end coding-system)))
 196             (defun mm-encode-coding-region (start end coding-system)
 197               (if coding-system
 198                   (encode-coding-region start end coding-system))))
 199         (defun mm-decode-coding-string (str coding-system) str)
 200         (defun mm-encode-coding-string (str coding-system) str)
 201         (defalias 'mm-decode-coding-region 'ignore)
 202         (defalias 'mm-encode-coding-region 'ignore))
 203     (defalias 'mm-decode-coding-string 'decode-coding-string)
 204     (defalias 'mm-encode-coding-string 'encode-coding-string)
 205     (defalias 'mm-decode-coding-region 'decode-coding-region)
 206     (defalias 'mm-encode-coding-region 'encode-coding-region)))
 207
 208 ;; `string-to-multibyte' is available only in Emacs.
 209 (defalias 'mm-string-to-multibyte (if (featurep 'xemacs)
 210                                       'identity
 211                                     'string-to-multibyte))
 212
 213 ;; `char-or-char-int-p' is an XEmacs function, not available in Emacs.
 214 (eval-and-compile
 215   (defalias 'mm-char-or-char-int-p
 216     (cond
 217      ((fboundp 'char-or-char-int-p) 'char-or-char-int-p)
 218      ((fboundp 'char-valid-p) 'char-valid-p)
 219      (t 'identity))))
 220
 221 ;; `ucs-to-char' is a function that Mule-UCS provides.
 222 (eval-and-compile
 223   (if (featurep 'xemacs)
 224       (cond ((and (fboundp 'unicode-to-char) ;; XEmacs 21.5.
 225                   (subrp (symbol-function 'unicode-to-char)))
 226              (if (featurep 'mule)
 227                  (defalias 'mm-ucs-to-char 'unicode-to-char)
 228                (defun mm-ucs-to-char (codepoint)
 229                  "Convert Unicode codepoint to character."
 230                  (or (unicode-to-char codepoint) ?#))))
 231             ((featurep 'mule)
 232              (defun mm-ucs-to-char (codepoint)
 233                "Convert Unicode codepoint to character."
 234                (if (fboundp 'ucs-to-char) ;; Mule-UCS is loaded.
 235                    (progn
 236                      (defalias 'mm-ucs-to-char
 237                        (lambda (codepoint)
 238                          "Convert Unicode codepoint to character."
 239                          (condition-case nil
 240                              (or (ucs-to-char codepoint) ?#)
 241                            (error ?#))))
 242                      (mm-ucs-to-char codepoint))
 243                  (condition-case nil
 244                      (or (int-to-char codepoint) ?#)
 245                    (error ?#)))))
 246             (t
 247              (defun mm-ucs-to-char (codepoint)
 248                "Convert Unicode codepoint to character."
 249                (condition-case nil
 250                    (or (int-to-char codepoint) ?#)
 251                  (error ?#)))))
 252     (if (let ((char (make-char 'japanese-jisx0208 36 34)))
 253           (eq char (decode-char 'ucs char)))
 254         ;; Emacs 23.
 255         (defalias 'mm-ucs-to-char 'identity)
 256       (defun mm-ucs-to-char (codepoint)
 257         "Convert Unicode codepoint to character."
 258         (or (decode-char 'ucs codepoint) ?#)))))
 259
 260 ;; Fixme:  This seems always to be used to read a MIME charset, so it
 261 ;; should be re-named and fixed (in Emacs) to offer completion only on
 262 ;; proper charset names (base coding systems which have a
 263 ;; mime-charset defined).  XEmacs doesn't believe in mime-charset;
 264 ;; test with
 265 ;;   `(or (coding-system-get 'iso-8859-1 'mime-charset)
 266 ;;        (coding-system-get 'iso-8859-1 :mime-charset))'
 267 ;; Actually, there should be an `mm-coding-system-mime-charset'.
 268 (eval-and-compile
 269   (defalias 'mm-read-coding-system
 270     (if (featurep 'emacs) 'read-coding-system
 271       (cond
 272        ((fboundp 'read-coding-system)
 273         (if (and (featurep 'xemacs)
 274                  (<= (string-to-number emacs-version) 21.1))
 275             (lambda (prompt &optional default-coding-system)
 276               (read-coding-system prompt))
 277           'read-coding-system))
 278        (t (lambda (prompt &optional default-coding-system)
 279             "Prompt the user for a coding system."
 280             (gnus-completing-read
 281              prompt (mapcar (lambda (s) (symbol-name (car s)))
 282                             mm-mime-mule-charset-alist))))))))
 283
 284 (defvar mm-coding-system-list nil)
 285 (defun mm-get-coding-system-list ()
 286   "Get the coding system list."
 287   (or mm-coding-system-list
 288       (setq mm-coding-system-list (mm-coding-system-list))))
 289
 290 (defun mm-coding-system-p (cs)
 291   "Return non-nil if CS is a symbol naming a coding system.
 292 In XEmacs, also return non-nil if CS is a coding system object.
 293 If CS is available, return CS itself in Emacs, and return a coding
 294 system object in XEmacs."
 295   (if (fboundp 'find-coding-system)
 296       (and cs (find-coding-system cs))
 297     (if (fboundp 'coding-system-p)
 298         (when (coding-system-p cs)
 299           cs)
 300       ;; no-MULE XEmacs:
 301       (car (memq cs (mm-get-coding-system-list))))))
 302
 303 (defun mm-codepage-setup (number &optional alias)
 304   "Create a coding system cpNUMBER.
 305 The coding system is created using `codepage-setup'.  If ALIAS is
 306 non-nil, an alias is created and added to
 307 `mm-charset-synonym-alist'.  If ALIAS is a string, it's used as
 308 the alias.  Else windows-NUMBER is used."
 309   (interactive
 310    (let ((completion-ignore-case t)
 311          (candidates (if (fboundp 'cp-supported-codepages)
 312                          (cp-supported-codepages)
 313                        ;; Removed in Emacs 23 (unicode), so signal an error:
 314                        (error "`codepage-setup' not present in this Emacs version"))))
 315      (list (gnus-completing-read "Setup DOS Codepage" candidates
 316                                  t nil nil "437"))))
 317   (when alias
 318     (setq alias (if (stringp alias)
 319                     (intern alias)
 320                   (intern (format "windows-%s" number)))))
 321   (let* ((cp (intern (format "cp%s" number))))
 322     (unless (mm-coding-system-p cp)
 323       (if (fboundp 'codepage-setup)     ; silence compiler
 324           (codepage-setup number)
 325         (error "`codepage-setup' not present in this Emacs version")))
 326     (when (and alias
 327                ;; Don't add alias if setup of cp failed.
 328                (mm-coding-system-p cp))
 329       (add-to-list 'mm-charset-synonym-alist (cons alias cp)))))
 330
 331 (defvar mm-charset-synonym-alist
 332   `(
 333     ;; Not in XEmacs, but it's not a proper MIME charset anyhow.
 334     ,@(unless (mm-coding-system-p 'x-ctext)
 335         '((x-ctext . ctext)))
 336     ;; ISO-8859-15 is very similar to ISO-8859-1.  But it's _different_ in 8
 337     ;; positions!
 338     ,@(unless (mm-coding-system-p 'iso-8859-15)
 339         '((iso-8859-15 . iso-8859-1)))
 340     ;; BIG-5HKSCS is similar to, but different than, BIG-5.
 341     ,@(unless (mm-coding-system-p 'big5-hkscs)
 342         '((big5-hkscs . big5)))
 343     ;; A Microsoft misunderstanding.
 344     ,@(when (and (not (mm-coding-system-p 'unicode))
 345                  (mm-coding-system-p 'utf-16-le))
 346         '((unicode . utf-16-le)))
 347     ;; A Microsoft misunderstanding.
 348     ,@(unless (mm-coding-system-p 'ks_c_5601-1987)
 349         (if (mm-coding-system-p 'cp949)
 350             '((ks_c_5601-1987 . cp949))
 351           '((ks_c_5601-1987 . euc-kr))))
 352     ;; Windows-31J is Windows Codepage 932.
 353     ,@(when (and (not (mm-coding-system-p 'windows-31j))
 354                  (mm-coding-system-p 'cp932))
 355         '((windows-31j . cp932)))
 356     ;; Charset name: GBK, Charset aliases: CP936, MS936, windows-936
 357     ;; http://www.iana.org/assignments/charset-reg/GBK
 358     ;; Emacs 22.1 has cp936, but not gbk, so we alias it:
 359     ,@(when (and (not (mm-coding-system-p 'gbk))
 360                  (mm-coding-system-p 'cp936))
 361         '((gbk . cp936)))
 362     ;; UTF8 is a bogus name for UTF-8
 363     ,@(when (and (not (mm-coding-system-p 'utf8))
 364                  (mm-coding-system-p 'utf-8))
 365         '((utf8 . utf-8)))
 366     ;; ISO8859-1 is a bogus name for ISO-8859-1
 367     ,@(when (and (not (mm-coding-system-p 'iso8859-1))
 368                  (mm-coding-system-p 'iso-8859-1))
 369         '((iso8859-1 . iso-8859-1)))
 370     ;; ISO_8859-1 is a bogus name for ISO-8859-1
 371     ,@(when (and (not (mm-coding-system-p 'iso_8859-1))
 372                  (mm-coding-system-p 'iso-8859-1))
 373         '((iso_8859-1 . iso-8859-1)))
 374     )
 375   "A mapping from unknown or invalid charset names to the real charset names.
 376
 377 See `mm-codepage-iso-8859-list' and `mm-codepage-ibm-list'.")
 378
 379 (defcustom mm-codepage-iso-8859-list
 380   (list 1250 ;; Windows-1250 is a variant of Latin-2 heavily used by Microsoft
 381         ;; Outlook users in Czech republic.  Use this to allow reading of
 382         ;; their e-mails.
 383         '(1252 . 1) ;; Windows-1252 is a superset of iso-8859-1 (West
 384                     ;; Europe).  See also `gnus-article-dumbquotes-map'.
 385         '(1254 . 9) ;; Windows-1254 is a superset of iso-8859-9 (Turkish).
 386         '(1255 . 8));; Windows-1255 is a superset of iso-8859-8 (Hebrew).
 387   "A list of Windows codepage numbers and iso-8859 charset numbers.
 388
 389 If an element is a number corresponding to a supported windows
 390 codepage, appropriate entries to `mm-charset-synonym-alist' are
 391 added by `mm-setup-codepage-iso-8859'.  An element may also be a
 392 cons cell where the car is a codepage number and the cdr is the
 393 corresponding number of an iso-8859 charset."
 394   :type '(list (set :inline t
 395                     (const 1250 :tag "Central and East European")
 396                     (const (1252 . 1) :tag "West European")
 397                     (const (1254 . 9) :tag "Turkish")
 398                     (const (1255 . 8) :tag "Hebrew"))
 399                (repeat :inline t
 400                        :tag "Other options"
 401                        (choice
 402                         (integer :tag "Windows codepage number")
 403                         (cons (integer :tag "Windows codepage number")
 404                               (integer :tag "iso-8859 charset  number")))))
 405   :version "22.1" ;; Gnus 5.10.9
 406   :group 'mime)
 407
 408 (defcustom mm-codepage-ibm-list
 409   (list 437 ;; (US etc.)
 410         860 ;; (Portugal)
 411         861 ;; (Iceland)
 412         862 ;; (Israel)
 413         863 ;; (Canadian French)
 414         865 ;; (Nordic)
 415         852 ;;
 416         850 ;; (Latin 1)
 417         855 ;; (Cyrillic)
 418         866 ;; (Cyrillic - Russian)
 419         857 ;; (Turkish)
 420         864 ;; (Arabic)
 421         869 ;; (Greek)
 422         874);; (Thai)
 423   ;; In Emacs 23 (unicode), cp... and ibm... are aliases.
 424   ;; Cf. http://thread.gmane.org/v9lkng5nwy.fsf@marauder.physik.uni-ulm.de
 425   "List of IBM codepage numbers.
 426
 427 The codepage mappings slighly differ between IBM and other vendors.
 428 See \"ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/IBM/README.TXT\".
 429
 430 If an element is a number corresponding to a supported windows
 431 codepage, appropriate entries to `mm-charset-synonym-alist' are
 432 added by `mm-setup-codepage-ibm'."
 433   :type '(list (set :inline t
 434                     (const 437 :tag "US etc.")
 435                     (const 860 :tag "Portugal")
 436                     (const 861 :tag "Iceland")
 437                     (const 862 :tag "Israel")
 438                     (const 863 :tag "Canadian French")
 439                     (const 865 :tag "Nordic")
 440                     (const 852)
 441                     (const 850 :tag "Latin 1")
 442                     (const 855 :tag "Cyrillic")
 443                     (const 866 :tag "Cyrillic - Russian")
 444                     (const 857 :tag "Turkish")
 445                     (const 864 :tag "Arabic")
 446                     (const 869 :tag "Greek")
 447                     (const 874 :tag "Thai"))
 448                (repeat :inline t
 449                        :tag "Other options"
 450                        (integer :tag "Codepage number")))
 451   :version "22.1" ;; Gnus 5.10.9
 452   :group 'mime)
 453
 454 (defun mm-setup-codepage-iso-8859 (&optional list)
 455   "Add appropriate entries to `mm-charset-synonym-alist'.
 456 Unless LIST is given, `mm-codepage-iso-8859-list' is used."
 457   (unless list
 458     (setq list mm-codepage-iso-8859-list))
 459   (dolist (i list)
 460     (let (cp windows iso)
 461       (if (consp i)
 462           (setq cp (intern (format "cp%d" (car i)))
 463                 windows (intern (format "windows-%d" (car i)))
 464                 iso (intern (format "iso-8859-%d" (cdr i))))
 465         (setq cp (intern (format "cp%d" i))
 466               windows (intern (format "windows-%d" i))))
 467       (unless (mm-coding-system-p windows)
 468         (if (mm-coding-system-p cp)
 469             (add-to-list 'mm-charset-synonym-alist (cons windows cp))
 470           (add-to-list 'mm-charset-synonym-alist (cons windows iso)))))))
 471
 472 (defun mm-setup-codepage-ibm (&optional list)
 473   "Add appropriate entries to `mm-charset-synonym-alist'.
 474 Unless LIST is given, `mm-codepage-ibm-list' is used."
 475   (unless list
 476     (setq list mm-codepage-ibm-list))
 477   (dolist (number list)
 478     (let ((ibm (intern (format "ibm%d" number)))
 479           (cp  (intern (format "cp%d" number))))
 480       (when (and (not (mm-coding-system-p ibm))
 481                  (mm-coding-system-p cp))
 482         (add-to-list 'mm-charset-synonym-alist (cons ibm cp))))))
 483
 484 ;; Initialize:
 485 (mm-setup-codepage-iso-8859)
 486 (mm-setup-codepage-ibm)
 487
 488 ;; Note: this has to be defined before `mm-charset-to-coding-system'.
 489 (defcustom mm-charset-eval-alist
 490   (if (featurep 'xemacs)
 491       nil ;; I don't know what would be useful for XEmacs.
 492     '(;; Emacs 22 provides autoloads for 1250-1258
 493       ;; (i.e. `mm-codepage-setup' does nothing).
 494       (windows-1250 . (mm-codepage-setup 1250 t))
 495       (windows-1251 . (mm-codepage-setup 1251 t))
 496       (windows-1253 . (mm-codepage-setup 1253 t))
 497       (windows-1257 . (mm-codepage-setup 1257 t))))
 498   "An alist of (CHARSET . FORM) pairs.
 499 If an article is encoded in an unknown CHARSET, FORM is
 500 evaluated.  This allows to load additional libraries providing
 501 charsets on demand.  If supported by your Emacs version, you
 502 could use `autoload-coding-system' here."
 503   :version "22.1" ;; Gnus 5.10.9
 504   :type '(list (set :inline t
 505                     (const (windows-1250 . (mm-codepage-setup 1250 t)))
 506                     (const (windows-1251 . (mm-codepage-setup 1251 t)))
 507                     (const (windows-1253 . (mm-codepage-setup 1253 t)))
 508                     (const (windows-1257 . (mm-codepage-setup 1257 t)))
 509                     (const (cp850 . (mm-codepage-setup 850 nil))))
 510                (repeat :inline t
 511                        :tag "Other options"
 512                        (cons (symbol :tag "charset")
 513                              (symbol :tag "form"))))
 514   :group 'mime)
 515 (put 'mm-charset-eval-alist 'risky-local-variable t)
 516
 517 (defvar mm-charset-override-alist)
 518
 519 ;; Note: this function has to be defined before `mm-charset-override-alist'
 520 ;; since it will use this function in order to determine its default value
 521 ;; when loading mm-util.elc.
 522 (defun mm-charset-to-coding-system (charset &optional lbt
 523                                             allow-override silent)
 524   "Return coding-system corresponding to CHARSET.
 525 CHARSET is a symbol naming a MIME charset.
 526 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
 527 used as the line break code type of the coding system.
 528
 529 If ALLOW-OVERRIDE is given, use `mm-charset-override-alist' to
 530 map undesired charset names to their replacement.  This should
 531 only be used for decoding, not for encoding.
 532
 533 A non-nil value of SILENT means don't issue a warning even if CHARSET
 534 is not available."
 535   ;; OVERRIDE is used (only) in `mm-decode-body' and `mm-decode-string'.
 536   (when (stringp charset)
 537     (setq charset (intern (downcase charset))))
 538   (when lbt
 539     (setq charset (intern (format "%s-%s" charset lbt))))
 540   (cond
 541    ((null charset)
 542     charset)
 543    ;; Running in a non-MULE environment.
 544    ((or (null (mm-get-coding-system-list))
 545         (not (fboundp 'coding-system-get)))
 546     charset)
 547    ;; Check override list quite early.  Should only used for decoding, not for
 548    ;; encoding!
 549    ((and allow-override
 550          (let ((cs (cdr (assq charset mm-charset-override-alist))))
 551            (and cs (mm-coding-system-p cs) cs))))
 552    ;; ascii
 553    ((or (eq charset 'us-ascii)
 554         (string-match "ansi.x3.4" (symbol-name charset)))
 555     'ascii)
 556    ;; Check to see whether we can handle this charset.  (This depends
 557    ;; on there being some coding system matching each `mime-charset'
 558    ;; property defined, as there should be.)
 559    ((and (mm-coding-system-p charset)
 560 ;;; Doing this would potentially weed out incorrect charsets.
 561 ;;;      charset
 562 ;;;      (eq charset (coding-system-get charset 'mime-charset))
 563          )
 564     charset)
 565    ;; Use coding system Emacs knows.
 566    ((and (fboundp 'coding-system-from-name)
 567          (coding-system-from-name charset)))
 568    ;; Eval expressions from `mm-charset-eval-alist'
 569    ((let* ((el (assq charset mm-charset-eval-alist))
 570            (cs (car el))
 571            (form (cdr el)))
 572       (and cs
 573            form
 574            (prog2
 575                ;; Avoid errors...
 576                (condition-case nil (eval form) (error nil))
 577                ;; (message "Failed to eval `%s'" form))
 578                (mm-coding-system-p cs)
 579              (message "Added charset `%s' via `mm-charset-eval-alist'" cs))
 580            cs)))
 581    ;; Translate invalid charsets.
 582    ((let ((cs (cdr (assq charset mm-charset-synonym-alist))))
 583       (and cs
 584            (mm-coding-system-p cs)
 585            ;; (message
 586            ;;  "Using synonym `%s' from `mm-charset-synonym-alist' for `%s'"
 587            ;;  cs charset)
 588            cs)))
 589    ;; Last resort: search the coding system list for entries which
 590    ;; have the right mime-charset in case the canonical name isn't
 591    ;; defined (though it should be).
 592    ((let (cs)
 593       ;; mm-get-coding-system-list returns a list of cs without lbt.
 594       ;; Do we need -lbt?
 595       (dolist (c (mm-get-coding-system-list))
 596         (if (and (null cs)
 597                  (eq charset (or (coding-system-get c :mime-charset)
 598                                  (coding-system-get c 'mime-charset))))
 599             (setq cs c)))
 600       (unless (or silent cs)
 601         ;; Warn the user about unknown charset:
 602         (if (fboundp 'gnus-message)
 603             (gnus-message 7 "Unknown charset: %s" charset)
 604           (message "Unknown charset: %s" charset)))
 605       cs))))
 606
 607 ;; Note: `mm-charset-to-coding-system' has to be defined before this.
 608 (defcustom mm-charset-override-alist
 609   ;; Note: pairs that cannot be used in the Emacs version currently running
 610   ;; will be removed.
 611   '((gb2312 . gbk)
 612     (iso-8859-1 . windows-1252)
 613     (iso-8859-8 . windows-1255)
 614     (iso-8859-9 . windows-1254))
 615   "A mapping from undesired charset names to their replacement.
 616
 617 You may add pairs like (iso-8859-1 . windows-1252) here,
 618 i.e. treat iso-8859-1 as windows-1252.  windows-1252 is a
 619 superset of iso-8859-1."
 620   :type
 621   '(list
 622     :convert-widget
 623     (lambda (widget)
 624       (let ((defaults
 625               (delq nil
 626                     (mapcar (lambda (pair)
 627                               (if (mm-charset-to-coding-system (cdr pair)
 628                                                                nil nil t)
 629                                   pair))
 630                             '((gb2312 . gbk)
 631                               (iso-8859-1 . windows-1252)
 632                               (iso-8859-8 . windows-1255)
 633                               (iso-8859-9 . windows-1254)
 634                               (undecided  . windows-1252)))))
 635             (val (copy-sequence (default-value 'mm-charset-override-alist)))
 636             pair rest)
 637         (while val
 638           (push (if (and (prog1
 639                              (setq pair (assq (caar val) defaults))
 640                            (setq defaults (delq pair defaults)))
 641                          (equal (car val) pair))
 642                     `(const ,pair)
 643                   `(cons :format "%v"
 644                          (const :format "(%v" ,(caar val))
 645                          (symbol :size 3 :format " . %v)\n" ,(cdar val))))
 646                 rest)
 647           (setq val (cdr val)))
 648         (while defaults
 649           (push `(const ,(pop defaults)) rest))
 650         (widget-convert
 651          'list
 652          `(set :inline t :format "%v" ,@(nreverse rest))
 653          `(repeat :inline t :tag "Other options"
 654                   (cons :format "%v"
 655                         (symbol :size 3 :format "(%v")
 656                         (symbol :size 3 :format " . %v)\n")))))))
 657   ;; Remove pairs that cannot be used in the Emacs version currently
 658   ;; running.  Note that this section will be evaluated when loading
 659   ;; mm-util.elc.
 660   :set (lambda (symbol value)
 661          (custom-set-default
 662           symbol (delq nil
 663                        (mapcar (lambda (pair)
 664                                  (if (mm-charset-to-coding-system (cdr pair)
 665                                                                   nil nil t)
 666                                      pair))
 667                                value))))
 668   :version "22.1" ;; Gnus 5.10.9
 669   :group 'mime)
 670
 671 (defvar mm-binary-coding-system
 672   (cond
 673    ((mm-coding-system-p 'binary) 'binary)
 674    ((mm-coding-system-p 'no-conversion) 'no-conversion)
 675    (t nil))
 676   "100% binary coding system.")
 677
 678 (defvar mm-text-coding-system
 679   (or (if (memq system-type '(windows-nt ms-dos))
 680           (and (mm-coding-system-p 'raw-text-dos) 'raw-text-dos)
 681         (and (mm-coding-system-p 'raw-text) 'raw-text))
 682       mm-binary-coding-system)
 683   "Text-safe coding system (For removing ^M).")
 684
 685 (defvar mm-text-coding-system-for-write nil
 686   "Text coding system for write.")
 687
 688 (defvar mm-auto-save-coding-system
 689   (cond
 690    ((mm-coding-system-p 'utf-8-emacs)   ; Mule 7
 691     (if (memq system-type '(windows-nt ms-dos))
 692         (if (mm-coding-system-p 'utf-8-emacs-dos)
 693             'utf-8-emacs-dos mm-binary-coding-system)
 694       'utf-8-emacs))
 695    ((mm-coding-system-p 'emacs-mule)
 696     (if (memq system-type '(windows-nt ms-dos))
 697         (if (mm-coding-system-p 'emacs-mule-dos)
 698             'emacs-mule-dos mm-binary-coding-system)
 699       'emacs-mule))
 700    ((mm-coding-system-p 'escape-quoted) 'escape-quoted)
 701    (t mm-binary-coding-system))
 702   "Coding system of auto save file.")
 703
 704 (defvar mm-universal-coding-system mm-auto-save-coding-system
 705   "The universal coding system.")
 706
 707 ;; Fixme: some of the cars here aren't valid MIME charsets.  That
 708 ;; should only matter with XEmacs, though.
 709 (defvar mm-mime-mule-charset-alist
 710   `((us-ascii ascii)
 711     (iso-8859-1 latin-iso8859-1)
 712     (iso-8859-2 latin-iso8859-2)
 713     (iso-8859-3 latin-iso8859-3)
 714     (iso-8859-4 latin-iso8859-4)
 715     (iso-8859-5 cyrillic-iso8859-5)
 716     ;; Non-mule (X)Emacs uses the last mule-charset for 8bit characters.
 717     ;; The fake mule-charset, gnus-koi8-r, tells Gnus that the default
 718     ;; charset is koi8-r, not iso-8859-5.
 719     (koi8-r cyrillic-iso8859-5 gnus-koi8-r)
 720     (iso-8859-6 arabic-iso8859-6)
 721     (iso-8859-7 greek-iso8859-7)
 722     (iso-8859-8 hebrew-iso8859-8)
 723     (iso-8859-9 latin-iso8859-9)
 724     (iso-8859-14 latin-iso8859-14)
 725     (iso-8859-15 latin-iso8859-15)
 726     (viscii vietnamese-viscii-lower)
 727     (iso-2022-jp latin-jisx0201 japanese-jisx0208 japanese-jisx0208-1978)
 728     (euc-kr korean-ksc5601)
 729     (gb2312 chinese-gb2312)
 730     (gbk chinese-gbk)
 731     (gb18030 gb18030-2-byte
 732              gb18030-4-byte-bmp gb18030-4-byte-smp
 733              gb18030-4-byte-ext-1 gb18030-4-byte-ext-2)
 734     (big5 chinese-big5-1 chinese-big5-2)
 735     (tibetan tibetan)
 736     (thai-tis620 thai-tis620)
 737     (windows-1251 cyrillic-iso8859-5)
 738     (iso-2022-7bit ethiopic arabic-1-column arabic-2-column)
 739     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
 740                    latin-jisx0201 japanese-jisx0208-1978
 741                    chinese-gb2312 japanese-jisx0208
 742                    korean-ksc5601 japanese-jisx0212)
 743     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
 744                     latin-jisx0201 japanese-jisx0208-1978
 745                     chinese-gb2312 japanese-jisx0208
 746                     korean-ksc5601 japanese-jisx0212
 747                     chinese-cns11643-1 chinese-cns11643-2)
 748     (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
 749                     cyrillic-iso8859-5 greek-iso8859-7
 750                     latin-jisx0201 japanese-jisx0208-1978
 751                     chinese-gb2312 japanese-jisx0208
 752                     korean-ksc5601 japanese-jisx0212
 753                     chinese-cns11643-1 chinese-cns11643-2
 754                     chinese-cns11643-3 chinese-cns11643-4
 755                     chinese-cns11643-5 chinese-cns11643-6
 756                     chinese-cns11643-7)
 757     (iso-2022-jp-3 latin-jisx0201 japanese-jisx0208-1978 japanese-jisx0208
 758                    japanese-jisx0213-1 japanese-jisx0213-2)
 759     (shift_jis latin-jisx0201 katakana-jisx0201 japanese-jisx0208)
 760     ,(cond ((fboundp 'unicode-precedence-list)
 761             (cons 'utf-8 (delq 'ascii (mapcar 'charset-name
 762                                               (unicode-precedence-list)))))
 763            ((or (not (fboundp 'charsetp)) ;; non-Mule case
 764                 (charsetp 'unicode-a)
 765                 (not (mm-coding-system-p 'mule-utf-8)))
 766             '(utf-8 unicode-a unicode-b unicode-c unicode-d unicode-e))
 767            (t ;; If we have utf-8 we're in Mule 5+.
 768             (append '(utf-8)
 769                     (delete 'ascii
 770                             (coding-system-get 'mule-utf-8 'safe-charsets))))))
 771   "Alist of MIME-charset/MULE-charsets.")
 772
 773 (defun mm-enrich-utf-8-by-mule-ucs ()
 774   "Make the `utf-8' MIME charset usable by the Mule-UCS package.
 775 This function will run when the `un-define' module is loaded under
 776 XEmacs, and fill the `utf-8' entry in `mm-mime-mule-charset-alist'
 777 with Mule charsets.  It is completely useless for Emacs."
 778   (when (boundp 'unicode-basic-translation-charset-order-list)
 779     (condition-case nil
 780         (let ((val (delq
 781                     'ascii
 782                     (copy-sequence
 783                      (symbol-value
 784                       'unicode-basic-translation-charset-order-list))))
 785               (elem (assq 'utf-8 mm-mime-mule-charset-alist)))
 786           (if elem
 787               (setcdr elem val)
 788             (setq mm-mime-mule-charset-alist
 789                   (nconc mm-mime-mule-charset-alist
 790                          (list (cons 'utf-8 val))))))
 791       (error))))
 792
 793 ;; Correct by construction, but should be unnecessary for Emacs:
 794 (if (featurep 'xemacs)
 795     (eval-after-load "un-define" '(mm-enrich-utf-8-by-mule-ucs))
 796   (when (and (fboundp 'coding-system-list)
 797              (fboundp 'sort-coding-systems))
 798     (let ((css (sort-coding-systems (coding-system-list 'base-only)))
 799           cs mime mule alist)
 800       (while css
 801         (setq cs (pop css)
 802               mime (or (coding-system-get cs :mime-charset); Emacs 23 (unicode)
 803                        (coding-system-get cs 'mime-charset)))
 804         (when (and mime
 805                    (not (eq t (setq mule
 806                                     (coding-system-get cs 'safe-charsets))))
 807                    (not (assq mime alist)))
 808           (push (cons mime (delq 'ascii mule)) alist)))
 809       (setq mm-mime-mule-charset-alist (nreverse alist)))))
 810
 811 (defvar mm-hack-charsets '(iso-8859-15 iso-2022-jp-2)
 812   "A list of special charsets.
 813 Valid elements include:
 814 `iso-8859-15'    convert ISO-8859-1, -9 to ISO-8859-15 if ISO-8859-15 exists.
 815 `iso-2022-jp-2'  convert ISO-2022-jp to ISO-2022-jp-2 if ISO-2022-jp-2 exists."
 816 )
 817
 818 (defvar mm-iso-8859-15-compatible
 819   '((iso-8859-1 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE")
 820     (iso-8859-9 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE\xD0\xDD\xDE\xF0\xFD\xFE"))
 821   "ISO-8859-15 exchangeable coding systems and inconvertible characters.")
 822
 823 (defvar mm-iso-8859-x-to-15-table
 824   (and (fboundp 'coding-system-p)
 825        (mm-coding-system-p 'iso-8859-15)
 826        (mapcar
 827         (lambda (cs)
 828           (if (mm-coding-system-p (car cs))
 829               (let ((c (string-to-char
 830                         (decode-coding-string "\341" (car cs)))))
 831                 (cons (char-charset c)
 832                       (cons
 833                        (- (string-to-char
 834                            (decode-coding-string "\341" 'iso-8859-15)) c)
 835                        (string-to-list (decode-coding-string (car (cdr cs))
 836                                                              (car cs))))))
 837             '(gnus-charset 0)))
 838         mm-iso-8859-15-compatible))
 839   "A table of the difference character between ISO-8859-X and ISO-8859-15.")
 840
 841 (defcustom mm-coding-system-priorities
 842   (let ((lang (if (boundp 'current-language-environment)
 843                   (symbol-value 'current-language-environment))))
 844     (cond (;; XEmacs without Mule but with `file-coding'.
 845            (not lang) nil)
 846           ;; In XEmacs 21.5 it may be the one like "Japanese (UTF-8)".
 847           ((string-match "\\`Japanese" lang)
 848            ;; Japanese users prefer iso-2022-jp to euc-japan or
 849            ;; shift_jis, however iso-8859-1 should be used when
 850            ;; there are only ASCII text and Latin-1 characters.
 851            '(iso-8859-1 iso-2022-jp iso-2022-jp-2 shift_jis utf-8))))
 852   "Preferred coding systems for encoding outgoing messages.
 853
 854 More than one suitable coding system may be found for some text.
 855 By default, the coding system with the highest priority is used
 856 to encode outgoing messages (see `sort-coding-systems').  If this
 857 variable is set, it overrides the default priority."
 858   :version "21.2"
 859   :type '(repeat (symbol :tag "Coding system"))
 860   :group 'mime)
 861
 862 ;; ??
 863 (defvar mm-use-find-coding-systems-region
 864   (fboundp 'find-coding-systems-region)
 865   "Use `find-coding-systems-region' to find proper coding systems.
 866
 867 Setting it to nil is useful on Emacsen supporting Unicode if sending
 868 mail with multiple parts is preferred to sending a Unicode one.")
 869
 870 (defvar mm-extra-numeric-entities
 871   (mapcar
 872    (lambda (item)
 873      (cons (car item) (mm-ucs-to-char (cdr item))))
 874    '((#x80 . #x20AC) (#x82 . #x201A) (#x83 . #x0192) (#x84 . #x201E)
 875      (#x85 . #x2026) (#x86 . #x2020) (#x87 . #x2021) (#x88 . #x02C6)
 876      (#x89 . #x2030) (#x8A . #x0160) (#x8B . #x2039) (#x8C . #x0152)
 877      (#x8E . #x017D) (#x91 . #x2018) (#x92 . #x2019) (#x93 . #x201C)
 878      (#x94 . #x201D) (#x95 . #x2022) (#x96 . #x2013) (#x97 . #x2014)
 879      (#x98 . #x02DC) (#x99 . #x2122) (#x9A . #x0161) (#x9B . #x203A)
 880      (#x9C . #x0153) (#x9E . #x017E) (#x9F . #x0178)))
 881   "*Alist of extra numeric entities and characters other than ISO 10646.
 882 This table is used for decoding extra numeric entities to characters,
 883 like \"&#128;\" to the euro sign, mainly in html messages.")
 884
 885 ;;; Internal variables:
 886
 887 ;;; Functions:
 888
 889 (defun mm-mule-charset-to-mime-charset (charset)
 890   "Return the MIME charset corresponding to the given Mule CHARSET."
 891   (if (and (fboundp 'find-coding-systems-for-charsets)
 892            (fboundp 'sort-coding-systems))
 893       (let ((css (sort (sort-coding-systems
 894                         (find-coding-systems-for-charsets (list charset)))
 895                        'mm-sort-coding-systems-predicate))
 896             cs mime)
 897         (while (and (not mime)
 898                     css)
 899           (when (setq cs (pop css))
 900             (setq mime (or (coding-system-get cs :mime-charset)
 901                            (coding-system-get cs 'mime-charset)))))
 902         mime)
 903     (let ((alist (mapcar (lambda (cs)
 904                            (assq cs mm-mime-mule-charset-alist))
 905                          (sort (mapcar 'car mm-mime-mule-charset-alist)
 906                                'mm-sort-coding-systems-predicate)))
 907           out)
 908       (while alist
 909         (when (memq charset (cdar alist))
 910           (setq out (caar alist)
 911                 alist nil))
 912         (pop alist))
 913       out)))
 914
 915 (eval-and-compile
 916   (if (featurep 'xemacs)
 917       (defalias 'mm-enable-multibyte 'ignore)
 918     (defun mm-enable-multibyte ()
 919       "Set the multibyte flag of the current buffer.
 920 Only do this if the default value of `enable-multibyte-characters' is
 921 non-nil.  This is a no-op in XEmacs."
 922       (set-buffer-multibyte 'to)))
 923
 924   (if (featurep 'xemacs)
 925       (defalias 'mm-disable-multibyte 'ignore)
 926     (defun mm-disable-multibyte ()
 927       "Unset the multibyte flag of in the current buffer.
 928 This is a no-op in XEmacs."
 929       (set-buffer-multibyte nil))))
 930
 931 (defun mm-preferred-coding-system (charset)
 932   ;; A typo in some Emacs versions.
 933   (or (get-charset-property charset 'preferred-coding-system)
 934       (get-charset-property charset 'prefered-coding-system)))
 935
 936 ;; Mule charsets shouldn't be used.
 937 (defsubst mm-guess-charset ()
 938   "Guess Mule charset from the language environment."
 939   (or
 940    mail-parse-mule-charset ;; cached mule-charset
 941    (progn
 942      (setq mail-parse-mule-charset
 943            (and (boundp 'current-language-environment)
 944                 (car (last
 945                       (assq 'charset
 946                             (assoc current-language-environment
 947                                    language-info-alist))))))
 948      (if (or (not mail-parse-mule-charset)
 949              (eq mail-parse-mule-charset 'ascii))
 950          (setq mail-parse-mule-charset
 951                (or (car (last (assq mail-parse-charset
 952                                     mm-mime-mule-charset-alist)))
 953                    ;; default
 954                    'latin-iso8859-1)))
 955      mail-parse-mule-charset)))
 956
 957 (defun mm-charset-after (&optional pos)
 958   "Return charset of a character in current buffer at position POS.
 959 If POS is nil, it defauls to the current point.
 960 If POS is out of range, the value is nil.
 961 If the charset is `composition', return the actual one."
 962   (let ((char (char-after pos)) charset)
 963     (if (< (mm-char-int char) 128)
 964         (setq charset 'ascii)
 965       ;; charset-after is fake in some Emacsen.
 966       (setq charset (and (fboundp 'char-charset) (char-charset char)))
 967       (if (eq charset 'composition)     ; Mule 4