mm-util.el 61.8 KB
Newer Older
1
;;; mm-util.el --- Utility functions for Mule and low level things
2 3

;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
Glenn Morris's avatar
Glenn Morris committed
4
;;   2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
Gerd Moellmann's avatar
Gerd Moellmann committed
5 6 7 8 9

;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;;	MORIOKA Tomohiko <morioka@jaist.ac.jp>
;; This file is part of GNU Emacs.

10
;; GNU Emacs is free software: you can redistribute it and/or modify
Gerd Moellmann's avatar
Gerd Moellmann committed
11
;; it under the terms of the GNU General Public License as published by
12 13
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Gerd Moellmann's avatar
Gerd Moellmann committed
14 15 16

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Gerd Moellmann's avatar
Gerd Moellmann committed
18 19 20
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
21
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
Gerd Moellmann's avatar
Gerd Moellmann committed
22 23 24 25 26

;;; Commentary:

;;; Code:

27 28 29 30
;; For Emacs < 22.2.
(eval-and-compile
  (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))

31
(eval-when-compile (require 'cl))
Gerd Moellmann's avatar
Gerd Moellmann committed
32 33
(require 'mail-prsvr)

Dave Love's avatar
Dave Love committed
34
(eval-and-compile
35 36 37 38 39 40
  (if (featurep 'xemacs)
      (unless (ignore-errors
		(require 'timer-funcs))
	(require 'timer))
    (require 'timer)))

Dan Nicolaescu's avatar
Dan Nicolaescu committed
41 42
(defvar mm-mime-mule-charset-alist )

Miles Bader's avatar
Miles Bader committed
43 44 45 46
;; Emulate functions that are not available in every (X)Emacs version.
;; The name of a function is prefixed with mm-, like `mm-char-int' for
;; `char-int' that is a native XEmacs function, not available in Emacs.
;; Gnus programs all should use mm- functions, not the original ones.
47 48
(eval-and-compile
  (mapc
Dave Love's avatar
Dave Love committed
49 50 51 52 53
   (lambda (elem)
     (let ((nfunc (intern (format "mm-%s" (car elem)))))
       (if (fboundp (car elem))
	   (defalias nfunc (car elem))
	 (defalias nfunc (cdr elem)))))
Miles Bader's avatar
Miles Bader committed
54 55 56 57
   `(;; `coding-system-list' is not available in XEmacs 21.4 built
     ;; without the `file-coding' feature.
     (coding-system-list . ignore)
     ;; `char-int' is an XEmacs function, not available in Emacs.
Dave Love's avatar
Dave Love committed
58
     (char-int . identity)
Miles Bader's avatar
Miles Bader committed
59
     ;; `coding-system-equal' is an Emacs function, not available in XEmacs.
Dave Love's avatar
Dave Love committed
60
     (coding-system-equal . equal)
Miles Bader's avatar
Miles Bader committed
61
     ;; `annotationp' is an XEmacs function, not available in Emacs.
Dave Love's avatar
Dave Love committed
62
     (annotationp . ignore)
Miles Bader's avatar
Miles Bader committed
63 64
     ;; `set-buffer-file-coding-system' is not available in XEmacs 21.4
     ;; built without the `file-coding' feature.
Dave Love's avatar
Dave Love committed
65
     (set-buffer-file-coding-system . ignore)
Miles Bader's avatar
Miles Bader committed
66
     ;; `read-charset' is an Emacs function, not available in XEmacs.
Dave Love's avatar
Dave Love committed
67
     (read-charset
Miles Bader's avatar
Miles Bader committed
68 69 70 71 72 73 74 75
      . ,(lambda (prompt)
	   "Return a charset."
	   (intern
	    (completing-read
	     prompt
	     (mapcar (lambda (e) (list (symbol-name (car e))))
		     mm-mime-mule-charset-alist)
	     nil t))))
Miles Bader's avatar
Miles Bader committed
76
     ;; `subst-char-in-string' is not available in XEmacs 21.4.
77
     (subst-char-in-string
Miles Bader's avatar
Miles Bader committed
78 79 80
      . ,(lambda (from to string &optional inplace)
	   ;; stolen (and renamed) from nnheader.el
	   "Replace characters in STRING from FROM to TO.
81
	  Unless optional argument INPLACE is non-nil, return a new string."
Miles Bader's avatar
Miles Bader committed
82 83 84 85 86 87 88 89 90
	   (let ((string (if inplace string (copy-sequence string)))
		 (len (length string))
		 (idx 0))
	     ;; Replace all occurrences of FROM with TO.
	     (while (< idx len)
	       (when (= (aref string idx) from)
		 (aset string idx to))
	       (setq idx (1+ idx)))
	     string)))
Miles Bader's avatar
Miles Bader committed
91
     ;; `replace-in-string' is an XEmacs function, not available in Emacs.
92
     (replace-in-string
Miles Bader's avatar
Miles Bader committed
93 94 95
      . ,(lambda (string regexp rep &optional literal)
	   "See `replace-regexp-in-string', only the order of args differs."
	   (replace-regexp-in-string regexp rep string nil literal)))
Miles Bader's avatar
Miles Bader committed
96
     ;; `string-as-unibyte' is an Emacs function, not available in XEmacs.
Dave Love's avatar
Dave Love committed
97
     (string-as-unibyte . identity)
Miles Bader's avatar
Miles Bader committed
98
     ;; `string-make-unibyte' is an Emacs function, not available in XEmacs.
99
     (string-make-unibyte . identity)
100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117
     ;; string-as-multibyte often doesn't really do what you think it does.
     ;; Example:
     ;;    (aref (string-as-multibyte "\201") 0) -> 129 (aka ?\201)
     ;;    (aref (string-as-multibyte "\300") 0) -> 192 (aka ?\300)
     ;;    (aref (string-as-multibyte "\300\201") 0) -> 192 (aka ?\300)
     ;;    (aref (string-as-multibyte "\300\201") 1) -> 129 (aka ?\201)
     ;; but
     ;;    (aref (string-as-multibyte "\201\300") 0) -> 2240
     ;;    (aref (string-as-multibyte "\201\300") 1) -> <error>
     ;; Better use string-to-multibyte or encode-coding-string.
     ;; If you really need string-as-multibyte somewhere it's usually
     ;; because you're using the internal emacs-mule representation (maybe
     ;; because you're using string-as-unibyte somewhere), which is
     ;; generally a problem in itself.
     ;; Here is an approximate equivalence table to help think about it:
     ;; (string-as-multibyte s)   ~= (decode-coding-string s 'emacs-mule)
     ;; (string-to-multibyte s)   ~= (decode-coding-string s 'binary)
     ;; (string-make-multibyte s) ~= (decode-coding-string s locale-coding-system)
Miles Bader's avatar
Miles Bader committed
118
     ;; `string-as-multibyte' is an Emacs function, not available in XEmacs.
119
     (string-as-multibyte . identity)
Miles Bader's avatar
Miles Bader committed
120
     ;; `multibyte-string-p' is an Emacs function, not available in XEmacs.
121
     (multibyte-string-p . ignore)
Miles Bader's avatar
Miles Bader committed
122
     ;; `insert-byte' is available only in Emacs 23.1 or greater.
123
     (insert-byte . insert-char)
Miles Bader's avatar
Miles Bader committed
124 125
     ;; `multibyte-char-to-unibyte' is an Emacs function, not available
     ;; in XEmacs.
126
     (multibyte-char-to-unibyte . identity)
Miles Bader's avatar
Miles Bader committed
127
     ;; `set-buffer-multibyte' is an Emacs function, not available in XEmacs.
128
     (set-buffer-multibyte . ignore)
Miles Bader's avatar
Miles Bader committed
129
     ;; `special-display-p' is an Emacs function, not available in XEmacs.
130
     (special-display-p
Miles Bader's avatar
Miles Bader committed
131 132 133 134 135 136 137 138 139 140 141 142 143 144
      . ,(lambda (buffer-name)
	   "Returns non-nil if a buffer named BUFFER-NAME gets a special frame."
	   (and special-display-function
		(or (and (member buffer-name special-display-buffer-names) t)
		    (cdr (assoc buffer-name special-display-buffer-names))
		    (catch 'return
		      (dolist (elem special-display-regexps)
			(and (stringp elem)
			     (string-match elem buffer-name)
			     (throw 'return t))
			(and (consp elem)
			     (stringp (car elem))
			     (string-match (car elem) buffer-name)
			     (throw 'return (cdr elem)))))))))
Miles Bader's avatar
Miles Bader committed
145
     ;; `substring-no-properties' is available only in Emacs 22.1 or greater.
Miles Bader's avatar
Miles Bader committed
146 147 148 149 150 151 152 153 154 155 156
     (substring-no-properties
      . ,(lambda (string &optional from to)
	   "Return a substring of STRING, without text properties.
It starts at index FROM and ending before TO.
TO may be nil or omitted; then the substring runs to the end of STRING.
If FROM is nil or omitted, the substring starts at the beginning of STRING.
If FROM or TO is negative, it counts from the end.

With one argument, just copy STRING without its properties."
	   (setq string (substring string (or from 0) to))
	   (set-text-properties 0 (length string) nil string)
Miles Bader's avatar
Miles Bader committed
157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172
	   string))
     ;; `line-number-at-pos' is available only in Emacs 22.1 or greater
     ;; and XEmacs 21.5.
     (line-number-at-pos
      . ,(lambda (&optional pos)
	   "Return (narrowed) buffer line number at position POS.
If POS is nil, use current buffer location.
Counting starts at (point-min), so the value refers
to the contents of the accessible portion of the buffer."
	   (let ((opoint (or pos (point))) start)
	     (save-excursion
	       (goto-char (point-min))
	       (setq start (point))
	       (goto-char opoint)
	       (forward-line 0)
	       (1+ (count-lines start (point))))))))))
Dave Love's avatar
Dave Love committed
173

Miles Bader's avatar
Miles Bader committed
174 175 176 177
;; `decode-coding-string', `encode-coding-string', `decode-coding-region'
;; and `encode-coding-region' are available in Emacs and XEmacs built with
;; the `file-coding' feature, but the XEmacs versions treat nil, that is
;; given as the `coding-system' argument, as the `binary' coding system.
Miles Bader's avatar
Miles Bader committed
178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204
(eval-and-compile
  (if (featurep 'xemacs)
      (if (featurep 'file-coding)
	  (progn
	    (defun mm-decode-coding-string (str coding-system)
	      (if coding-system
		  (decode-coding-string str coding-system)
		str))
	    (defun mm-encode-coding-string (str coding-system)
	      (if coding-system
		  (encode-coding-string str coding-system)
		str))
	    (defun mm-decode-coding-region (start end coding-system)
	      (if coding-system
		  (decode-coding-region start end coding-system)))
	    (defun mm-encode-coding-region (start end coding-system)
	      (if coding-system
		  (encode-coding-region start end coding-system))))
	(defun mm-decode-coding-string (str coding-system) str)
	(defun mm-encode-coding-string (str coding-system) str)
	(defalias 'mm-decode-coding-region 'ignore)
	(defalias 'mm-encode-coding-region 'ignore))
    (defalias 'mm-decode-coding-string 'decode-coding-string)
    (defalias 'mm-encode-coding-string 'encode-coding-string)
    (defalias 'mm-decode-coding-region 'decode-coding-region)
    (defalias 'mm-encode-coding-region 'encode-coding-region)))

Miles Bader's avatar
Miles Bader committed
205
;; `string-to-multibyte' is available only in Emacs 22.1 or greater.
Miles Bader's avatar
Miles Bader committed
206 207 208 209 210 211 212 213
(defalias 'mm-string-to-multibyte
  (cond
   ((featurep 'xemacs)
    'identity)
   ((fboundp 'string-to-multibyte)
    'string-to-multibyte)
   (t
    (lambda (string)
Miles Bader's avatar
Miles Bader committed
214
      "Return a multibyte string with the same individual chars as STRING."
Miles Bader's avatar
Miles Bader committed
215 216 217 218
      (mapconcat
       (lambda (ch) (mm-string-as-multibyte (char-to-string ch)))
       string "")))))

Miles Bader's avatar
Miles Bader committed
219
;; `char-or-char-int-p' is an XEmacs function, not available in Emacs.
Gerd Moellmann's avatar
Gerd Moellmann committed
220 221
(eval-and-compile
  (defalias 'mm-char-or-char-int-p
222
    (cond
Gerd Moellmann's avatar
Gerd Moellmann committed
223
     ((fboundp 'char-or-char-int-p) 'char-or-char-int-p)
224
     ((fboundp 'char-valid-p) 'char-valid-p)
Gerd Moellmann's avatar
Gerd Moellmann committed
225 226
     (t 'identity))))

Miles Bader's avatar
Miles Bader committed
227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264
;; `ucs-to-char' is a function that Mule-UCS provides.
(if (featurep 'xemacs)
    (cond ((and (fboundp 'unicode-to-char) ;; XEmacs 21.5.
		(subrp (symbol-function 'unicode-to-char)))
	   (if (featurep 'mule)
	       (defalias 'mm-ucs-to-char 'unicode-to-char)
	     (defun mm-ucs-to-char (codepoint)
	       "Convert Unicode codepoint to character."
	       (or (unicode-to-char codepoint) ?#))))
	  ((featurep 'mule)
	   (defun mm-ucs-to-char (codepoint)
	     "Convert Unicode codepoint to character."
	     (if (fboundp 'ucs-to-char) ;; Mule-UCS is loaded.
		 (progn
		   (defalias 'mm-ucs-to-char
		     (lambda (codepoint)
		       "Convert Unicode codepoint to character."
		       (condition-case nil
			   (or (ucs-to-char codepoint) ?#)
			 (error ?#))))
		   (mm-ucs-to-char codepoint))
	       (condition-case nil
		   (or (int-to-char codepoint) ?#)
		 (error ?#)))))
	  (t
	   (defun mm-ucs-to-char (codepoint)
	     "Convert Unicode codepoint to character."
	     (condition-case nil
		 (or (int-to-char codepoint) ?#)
	       (error ?#)))))
  (if (let ((char (make-char 'japanese-jisx0208 36 34)))
	(eq char (decode-char 'ucs char)))
      ;; Emacs 23.
      (defalias 'mm-ucs-to-char 'identity)
    (defun mm-ucs-to-char (codepoint)
      "Convert Unicode codepoint to character."
      (or (decode-char 'ucs codepoint) ?#))))

265 266 267 268 269 270 271 272
;; Fixme:  This seems always to be used to read a MIME charset, so it
;; should be re-named and fixed (in Emacs) to offer completion only on
;; proper charset names (base coding systems which have a
;; mime-charset defined).  XEmacs doesn't believe in mime-charset;
;; test with
;;   `(or (coding-system-get 'iso-8859-1 'mime-charset)
;;        (coding-system-get 'iso-8859-1 :mime-charset))'
;; Actually, there should be an `mm-coding-system-mime-charset'.
273 274 275 276 277 278 279 280 281 282 283 284 285 286 287
(eval-and-compile
  (defalias 'mm-read-coding-system
    (cond
     ((fboundp 'read-coding-system)
      (if (and (featurep 'xemacs)
	       (<= (string-to-number emacs-version) 21.1))
	  (lambda (prompt &optional default-coding-system)
	    (read-coding-system prompt))
	'read-coding-system))
     (t (lambda (prompt &optional default-coding-system)
	  "Prompt the user for a coding system."
	  (completing-read
	   prompt (mapcar (lambda (s) (list (symbol-name (car s))))
			  mm-mime-mule-charset-alist)))))))

Gerd Moellmann's avatar
Gerd Moellmann committed
288 289 290 291 292 293
(defvar mm-coding-system-list nil)
(defun mm-get-coding-system-list ()
  "Get the coding system list."
  (or mm-coding-system-list
      (setq mm-coding-system-list (mm-coding-system-list))))

294 295
(defun mm-coding-system-p (cs)
  "Return non-nil if CS is a symbol naming a coding system.
296 297 298
In XEmacs, also return non-nil if CS is a coding system object.
If CS is available, return CS itself in Emacs, and return a coding
system object in XEmacs."
299
  (if (fboundp 'find-coding-system)
300
      (and cs (find-coding-system cs))
301
    (if (fboundp 'coding-system-p)
302 303
	(when (coding-system-p cs)
	  cs)
304
      ;; no-MULE XEmacs:
305
      (car (memq cs (mm-get-coding-system-list))))))
306

307 308 309 310 311 312 313 314
(defun mm-codepage-setup (number &optional alias)
  "Create a coding system cpNUMBER.
The coding system is created using `codepage-setup'.  If ALIAS is
non-nil, an alias is created and added to
`mm-charset-synonym-alist'.  If ALIAS is a string, it's used as
the alias.  Else windows-NUMBER is used."
  (interactive
   (let ((completion-ignore-case t)
315 316
	 (candidates (if (fboundp 'cp-supported-codepages)
			 (cp-supported-codepages)
317 318
		       ;; Removed in Emacs 23 (unicode), so signal an error:
		       (error "`codepage-setup' not present in this Emacs version."))))
319 320 321 322 323 324 325 326
     (list (completing-read "Setup DOS Codepage: (default 437) " candidates
			    nil t nil nil "437"))))
  (when alias
    (setq alias (if (stringp alias)
		    (intern alias)
		  (intern (format "windows-%s" number)))))
  (let* ((cp (intern (format "cp%s" number))))
    (unless (mm-coding-system-p cp)
327 328 329
      (if (fboundp 'codepage-setup)	; silence compiler
	  (codepage-setup number)
	(error "`codepage-setup' not present in this Emacs version.")))
330 331 332 333 334
    (when (and alias
	       ;; Don't add alias if setup of cp failed.
	       (mm-coding-system-p cp))
      (add-to-list 'mm-charset-synonym-alist (cons alias cp)))))

Gerd Moellmann's avatar
Gerd Moellmann committed
335
(defvar mm-charset-synonym-alist
336 337
  `(
    ;; Not in XEmacs, but it's not a proper MIME charset anyhow.
338
    ,@(unless (mm-coding-system-p 'x-ctext)
Miles Bader's avatar
Miles Bader committed
339
	'((x-ctext . ctext)))
Miles Bader's avatar
Miles Bader committed
340 341
    ;; ISO-8859-15 is very similar to ISO-8859-1.  But it's _different_ in 8
    ;; positions!
342
    ,@(unless (mm-coding-system-p 'iso-8859-15)
Miles Bader's avatar
Miles Bader committed
343
	'((iso-8859-15 . iso-8859-1)))
344 345 346
    ;; BIG-5HKSCS is similar to, but different than, BIG-5.
    ,@(unless (mm-coding-system-p 'big5-hkscs)
	'((big5-hkscs . big5)))
347
    ;; A Microsoft misunderstanding.
Miles Bader's avatar
Miles Bader committed
348 349 350
    ,@(when (and (not (mm-coding-system-p 'unicode))
		 (mm-coding-system-p 'utf-16-le))
	'((unicode . utf-16-le)))
351 352 353 354 355
    ;; A Microsoft misunderstanding.
    ,@(unless (mm-coding-system-p 'ks_c_5601-1987)
	(if (mm-coding-system-p 'cp949)
	    '((ks_c_5601-1987 . cp949))
	  '((ks_c_5601-1987 . euc-kr))))
Miles Bader's avatar
Miles Bader committed
356
    ;; Windows-31J is Windows Codepage 932.
Miles Bader's avatar
Miles Bader committed
357 358 359
    ,@(when (and (not (mm-coding-system-p 'windows-31j))
		 (mm-coding-system-p 'cp932))
	'((windows-31j . cp932)))
Miles Bader's avatar
Miles Bader committed
360 361 362 363 364 365
    ;; Charset name: GBK, Charset aliases: CP936, MS936, windows-936
    ;; http://www.iana.org/assignments/charset-reg/GBK
    ;; Emacs 22.1 has cp936, but not gbk, so we alias it:
    ,@(when (and (not (mm-coding-system-p 'gbk))
		 (mm-coding-system-p 'cp936))
	'((gbk . cp936)))
Miles Bader's avatar
Miles Bader committed
366 367 368 369
    ;; UTF8 is a bogus name for UTF-8
    ,@(when (and (not (mm-coding-system-p 'utf8))
		 (mm-coding-system-p 'utf-8))
	'((utf8 . utf-8)))
370 371 372 373
    ;; ISO8859-1 is a bogus name for ISO-8859-1
    ,@(when (and (not (mm-coding-system-p 'iso8859-1))
		 (mm-coding-system-p 'iso-8859-1))
	'((iso8859-1 . iso-8859-1)))
Miles Bader's avatar
Miles Bader committed
374 375 376 377
    ;; ISO_8859-1 is a bogus name for ISO-8859-1
    ,@(when (and (not (mm-coding-system-p 'iso_8859-1))
		 (mm-coding-system-p 'iso-8859-1))
	'((iso_8859-1 . iso-8859-1)))
378
    )
Miles Bader's avatar
Miles Bader committed
379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491
  "A mapping from unknown or invalid charset names to the real charset names.

See `mm-codepage-iso-8859-list' and `mm-codepage-ibm-list'.")

(defcustom mm-codepage-iso-8859-list
  (list 1250 ;; Windows-1250 is a variant of Latin-2 heavily used by Microsoft
	;; Outlook users in Czech republic.  Use this to allow reading of
	;; their e-mails.  cp1250 should be defined by M-x codepage-setup
	;; (Emacs 21).
	'(1252 . 1) ;; Windows-1252 is a superset of iso-8859-1 (West
	            ;; Europe).  See also `gnus-article-dumbquotes-map'.
	'(1254 . 9) ;; Windows-1254 is a superset of iso-8859-9 (Turkish).
	'(1255 . 8));; Windows-1255 is a superset of iso-8859-8 (Hebrew).
  "A list of Windows codepage numbers and iso-8859 charset numbers.

If an element is a number corresponding to a supported windows
codepage, appropriate entries to `mm-charset-synonym-alist' are
added by `mm-setup-codepage-iso-8859'.  An element may also be a
cons cell where the car is a codepage number and the cdr is the
corresponding number of an iso-8859 charset."
  :type '(list (set :inline t
		    (const 1250 :tag "Central and East European")
		    (const (1252 . 1) :tag "West European")
		    (const (1254 . 9) :tag "Turkish")
		    (const (1255 . 8) :tag "Hebrew"))
	       (repeat :inline t
		       :tag "Other options"
		       (choice
			(integer :tag "Windows codepage number")
			(cons (integer :tag "Windows codepage number")
			      (integer :tag "iso-8859 charset  number")))))
  :version "22.1" ;; Gnus 5.10.9
  :group 'mime)

(defcustom mm-codepage-ibm-list
  (list 437 ;; (US etc.)
	860 ;; (Portugal)
	861 ;; (Iceland)
	862 ;; (Israel)
	863 ;; (Canadian French)
	865 ;; (Nordic)
	852 ;;
	850 ;; (Latin 1)
	855 ;; (Cyrillic)
	866 ;; (Cyrillic - Russian)
	857 ;; (Turkish)
	864 ;; (Arabic)
	869 ;; (Greek)
	874);; (Thai)
  ;; In Emacs 23 (unicode), cp... and ibm... are aliases.
  ;; Cf. http://thread.gmane.org/v9lkng5nwy.fsf@marauder.physik.uni-ulm.de
  "List of IBM codepage numbers.

The codepage mappings slighly differ between IBM and other vendors.
See \"ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/IBM/README.TXT\".

If an element is a number corresponding to a supported windows
codepage, appropriate entries to `mm-charset-synonym-alist' are
added by `mm-setup-codepage-ibm'."
  :type '(list (set :inline t
		    (const 437 :tag "US etc.")
		    (const 860 :tag "Portugal")
		    (const 861 :tag "Iceland")
		    (const 862 :tag "Israel")
		    (const 863 :tag "Canadian French")
		    (const 865 :tag "Nordic")
		    (const 852)
		    (const 850 :tag "Latin 1")
		    (const 855 :tag "Cyrillic")
		    (const 866 :tag "Cyrillic - Russian")
		    (const 857 :tag "Turkish")
		    (const 864 :tag "Arabic")
		    (const 869 :tag "Greek")
		    (const 874 :tag "Thai"))
	       (repeat :inline t
		       :tag "Other options"
		       (integer :tag "Codepage number")))
  :version "22.1" ;; Gnus 5.10.9
  :group 'mime)

(defun mm-setup-codepage-iso-8859 (&optional list)
  "Add appropriate entries to `mm-charset-synonym-alist'.
Unless LIST is given, `mm-codepage-iso-8859-list' is used."
  (unless list
    (setq list mm-codepage-iso-8859-list))
  (dolist (i list)
    (let (cp windows iso)
      (if (consp i)
	  (setq cp (intern (format "cp%d" (car i)))
		windows (intern (format "windows-%d" (car i)))
		iso (intern (format "iso-8859-%d" (cdr i))))
	(setq cp (intern (format "cp%d" i))
	      windows (intern (format "windows-%d" i))))
      (unless (mm-coding-system-p windows)
	(if (mm-coding-system-p cp)
	    (add-to-list 'mm-charset-synonym-alist (cons windows cp))
	  (add-to-list 'mm-charset-synonym-alist (cons windows iso)))))))

(defun mm-setup-codepage-ibm (&optional list)
  "Add appropriate entries to `mm-charset-synonym-alist'.
Unless LIST is given, `mm-codepage-ibm-list' is used."
  (unless list
    (setq list mm-codepage-ibm-list))
  (dolist (number list)
    (let ((ibm (intern (format "ibm%d" number)))
	  (cp  (intern (format "cp%d" number))))
      (when (and (not (mm-coding-system-p ibm))
		 (mm-coding-system-p cp))
	(add-to-list 'mm-charset-synonym-alist (cons ibm cp))))))

;; Initialize:
(mm-setup-codepage-iso-8859)
(mm-setup-codepage-ibm)
492

493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521
;; Note: this has to be defined before `mm-charset-to-coding-system'.
(defcustom mm-charset-eval-alist
  (if (featurep 'xemacs)
      nil ;; I don't know what would be useful for XEmacs.
    '(;; Emacs 21 offers 1250 1251 1253 1257.  Emacs 22 provides autoloads for
      ;; 1250-1258 (i.e. `mm-codepage-setup' does nothing).
      (windows-1250 . (mm-codepage-setup 1250 t))
      (windows-1251 . (mm-codepage-setup 1251 t))
      (windows-1253 . (mm-codepage-setup 1253 t))
      (windows-1257 . (mm-codepage-setup 1257 t))))
  "An alist of (CHARSET . FORM) pairs.
If an article is encoded in an unknown CHARSET, FORM is
evaluated.  This allows to load additional libraries providing
charsets on demand.  If supported by your Emacs version, you
could use `autoload-coding-system' here."
  :version "22.1" ;; Gnus 5.10.9
  :type '(list (set :inline t
		    (const (windows-1250 . (mm-codepage-setup 1250 t)))
		    (const (windows-1251 . (mm-codepage-setup 1251 t)))
		    (const (windows-1253 . (mm-codepage-setup 1253 t)))
		    (const (windows-1257 . (mm-codepage-setup 1257 t)))
		    (const (cp850 . (mm-codepage-setup 850 nil))))
	       (repeat :inline t
		       :tag "Other options"
		       (cons (symbol :tag "charset")
			     (symbol :tag "form"))))
  :group 'mime)
(put 'mm-charset-eval-alist 'risky-local-variable t)

522 523
(defvar mm-charset-override-alist)

524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608
;; Note: this function has to be defined before `mm-charset-override-alist'
;; since it will use this function in order to determine its default value
;; when loading mm-util.elc.
(defun mm-charset-to-coding-system (charset &optional lbt
					    allow-override silent)
  "Return coding-system corresponding to CHARSET.
CHARSET is a symbol naming a MIME charset.
If optional argument LBT (`unix', `dos' or `mac') is specified, it is
used as the line break code type of the coding system.

If ALLOW-OVERRIDE is given, use `mm-charset-override-alist' to
map undesired charset names to their replacement.  This should
only be used for decoding, not for encoding.

A non-nil value of SILENT means don't issue a warning even if CHARSET
is not available."
  ;; OVERRIDE is used (only) in `mm-decode-body' and `mm-decode-string'.
  (when (stringp charset)
    (setq charset (intern (downcase charset))))
  (when lbt
    (setq charset (intern (format "%s-%s" charset lbt))))
  (cond
   ((null charset)
    charset)
   ;; Running in a non-MULE environment.
   ((or (null (mm-get-coding-system-list))
	(not (fboundp 'coding-system-get)))
    charset)
   ;; Check override list quite early.  Should only used for decoding, not for
   ;; encoding!
   ((and allow-override
	 (let ((cs (cdr (assq charset mm-charset-override-alist))))
	   (and cs (mm-coding-system-p cs) cs))))
   ;; ascii
   ((eq charset 'us-ascii)
    'ascii)
   ;; Check to see whether we can handle this charset.  (This depends
   ;; on there being some coding system matching each `mime-charset'
   ;; property defined, as there should be.)
   ((and (mm-coding-system-p charset)
;;; Doing this would potentially weed out incorrect charsets.
;;; 	 charset
;;; 	 (eq charset (coding-system-get charset 'mime-charset))
	 )
    charset)
   ;; Eval expressions from `mm-charset-eval-alist'
   ((let* ((el (assq charset mm-charset-eval-alist))
	   (cs (car el))
	   (form (cdr el)))
      (and cs
	   form
	   (prog2
	       ;; Avoid errors...
	       (condition-case nil (eval form) (error nil))
	       ;; (message "Failed to eval `%s'" form))
	       (mm-coding-system-p cs)
	     (message "Added charset `%s' via `mm-charset-eval-alist'" cs))
	   cs)))
   ;; Translate invalid charsets.
   ((let ((cs (cdr (assq charset mm-charset-synonym-alist))))
      (and cs
	   (mm-coding-system-p cs)
	   ;; (message
	   ;;  "Using synonym `%s' from `mm-charset-synonym-alist' for `%s'"
	   ;;  cs charset)
	   cs)))
   ;; Last resort: search the coding system list for entries which
   ;; have the right mime-charset in case the canonical name isn't
   ;; defined (though it should be).
   ((let (cs)
      ;; mm-get-coding-system-list returns a list of cs without lbt.
      ;; Do we need -lbt?
      (dolist (c (mm-get-coding-system-list))
	(if (and (null cs)
		 (eq charset (or (coding-system-get c :mime-charset)
				 (coding-system-get c 'mime-charset))))
	    (setq cs c)))
      (unless (or silent cs)
	;; Warn the user about unknown charset:
	(if (fboundp 'gnus-message)
	    (gnus-message 7 "Unknown charset: %s" charset)
	  (message "Unknown charset: %s" charset)))
      cs))))

;; Note: `mm-charset-to-coding-system' has to be defined before this.
609
(defcustom mm-charset-override-alist
610 611 612 613
  ;; Note: pairs that cannot be used in the Emacs version currently running
  ;; will be removed.
  '((gb2312 . gbk)
    (iso-8859-1 . windows-1252)
614 615
    (iso-8859-8 . windows-1255)
    (iso-8859-9 . windows-1254))
616 617 618 619 620
  "A mapping from undesired charset names to their replacement.

You may add pairs like (iso-8859-1 . windows-1252) here,
i.e. treat iso-8859-1 as windows-1252.  windows-1252 is a
superset of iso-8859-1."
621 622 623 624 625 626 627
  :type
  '(list
    :convert-widget
    (lambda (widget)
      (let ((defaults
	      (delq nil
		    (mapcar (lambda (pair)
628 629
			      (if (mm-charset-to-coding-system (cdr pair)
							       nil nil t)
630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657
				  pair))
			    '((gb2312 . gbk)
			      (iso-8859-1 . windows-1252)
			      (iso-8859-8 . windows-1255)
			      (iso-8859-9 . windows-1254)
			      (undecided  . windows-1252)))))
	    (val (copy-sequence (default-value 'mm-charset-override-alist)))
	    pair rest)
	(while val
	  (push (if (and (prog1
			     (setq pair (assq (caar val) defaults))
			   (setq defaults (delq pair defaults)))
			 (equal (car val) pair))
		    `(const ,pair)
		  `(cons :format "%v"
			 (const :format "(%v" ,(caar val))
			 (symbol :size 3 :format " . %v)\n" ,(cdar val))))
		rest)
	  (setq val (cdr val)))
	(while defaults
	  (push `(const ,(pop defaults)) rest))
	(widget-convert
	 'list
	 `(set :inline t :format "%v" ,@(nreverse rest))
	 `(repeat :inline t :tag "Other options"
		  (cons :format "%v"
			(symbol :size 3 :format "(%v")
			(symbol :size 3 :format " . %v)\n")))))))
658 659 660 661 662 663 664 665 666 667 668
  ;; Remove pairs that cannot be used in the Emacs version currently
  ;; running.  Note that this section will be evaluated when loading
  ;; mm-util.elc.
  :set (lambda (symbol value)
	 (custom-set-default
	  symbol (delq nil
		       (mapcar (lambda (pair)
				 (if (mm-charset-to-coding-system (cdr pair)
								  nil nil t)
				     pair))
			       value))))
Miles Bader's avatar
Miles Bader committed
669
  :version "22.1" ;; Gnus 5.10.9
670 671
  :group 'mime)

Gerd Moellmann's avatar
Gerd Moellmann committed
672
(defvar mm-binary-coding-system
673
  (cond
Gerd Moellmann's avatar
Gerd Moellmann committed
674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689
   ((mm-coding-system-p 'binary) 'binary)
   ((mm-coding-system-p 'no-conversion) 'no-conversion)
   (t nil))
  "100% binary coding system.")

(defvar mm-text-coding-system
  (or (if (memq system-type '(windows-nt ms-dos ms-windows))
	  (and (mm-coding-system-p 'raw-text-dos) 'raw-text-dos)
	(and (mm-coding-system-p 'raw-text) 'raw-text))
      mm-binary-coding-system)
  "Text-safe coding system (For removing ^M).")

(defvar mm-text-coding-system-for-write nil
  "Text coding system for write.")

(defvar mm-auto-save-coding-system
690
  (cond
691
   ((mm-coding-system-p 'utf-8-emacs)	; Mule 7
692 693 694 695
    (if (memq system-type '(windows-nt ms-dos ms-windows))
	(if (mm-coding-system-p 'utf-8-emacs-dos)
	    'utf-8-emacs-dos mm-binary-coding-system)
      'utf-8-emacs))
Gerd Moellmann's avatar
Gerd Moellmann committed
696 697
   ((mm-coding-system-p 'emacs-mule)
    (if (memq system-type '(windows-nt ms-dos ms-windows))
698
	(if (mm-coding-system-p 'emacs-mule-dos)
Gerd Moellmann's avatar
Gerd Moellmann committed
699 700 701 702 703 704
	    'emacs-mule-dos mm-binary-coding-system)
      'emacs-mule))
   ((mm-coding-system-p 'escape-quoted) 'escape-quoted)
   (t mm-binary-coding-system))
  "Coding system of auto save file.")

705
(defvar mm-universal-coding-system mm-auto-save-coding-system
706
  "The universal coding system.")
707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730

;; Fixme: some of the cars here aren't valid MIME charsets.  That
;; should only matter with XEmacs, though.
(defvar mm-mime-mule-charset-alist
  `((us-ascii ascii)
    (iso-8859-1 latin-iso8859-1)
    (iso-8859-2 latin-iso8859-2)
    (iso-8859-3 latin-iso8859-3)
    (iso-8859-4 latin-iso8859-4)
    (iso-8859-5 cyrillic-iso8859-5)
    ;; Non-mule (X)Emacs uses the last mule-charset for 8bit characters.
    ;; The fake mule-charset, gnus-koi8-r, tells Gnus that the default
    ;; charset is koi8-r, not iso-8859-5.
    (koi8-r cyrillic-iso8859-5 gnus-koi8-r)
    (iso-8859-6 arabic-iso8859-6)
    (iso-8859-7 greek-iso8859-7)
    (iso-8859-8 hebrew-iso8859-8)
    (iso-8859-9 latin-iso8859-9)
    (iso-8859-14 latin-iso8859-14)
    (iso-8859-15 latin-iso8859-15)
    (viscii vietnamese-viscii-lower)
    (iso-2022-jp latin-jisx0201 japanese-jisx0208 japanese-jisx0208-1978)
    (euc-kr korean-ksc5601)
    (gb2312 chinese-gb2312)
731 732 733 734
    (gbk chinese-gbk)
    (gb18030 gb18030-2-byte
	     gb18030-4-byte-bmp gb18030-4-byte-smp
	     gb18030-4-byte-ext-1 gb18030-4-byte-ext-2)
735 736 737
    (big5 chinese-big5-1 chinese-big5-2)
    (tibetan tibetan)
    (thai-tis620 thai-tis620)
738
    (windows-1251 cyrillic-iso8859-5)
739 740 741 742
    (iso-2022-7bit ethiopic arabic-1-column arabic-2-column)
    (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
		   latin-jisx0201 japanese-jisx0208-1978
		   chinese-gb2312 japanese-jisx0208
743
		   korean-ksc5601 japanese-jisx0212)
744 745 746 747 748 749 750 751 752 753 754 755 756 757
    (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
		    latin-jisx0201 japanese-jisx0208-1978
		    chinese-gb2312 japanese-jisx0208
		    korean-ksc5601 japanese-jisx0212
		    chinese-cns11643-1 chinese-cns11643-2)
    (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
		    cyrillic-iso8859-5 greek-iso8859-7
		    latin-jisx0201 japanese-jisx0208-1978
		    chinese-gb2312 japanese-jisx0208
		    korean-ksc5601 japanese-jisx0212
		    chinese-cns11643-1 chinese-cns11643-2
		    chinese-cns11643-3 chinese-cns11643-4
		    chinese-cns11643-5 chinese-cns11643-6
		    chinese-cns11643-7)
758 759 760
    (iso-2022-jp-3 latin-jisx0201 japanese-jisx0208-1978 japanese-jisx0208
		   japanese-jisx0213-1 japanese-jisx0213-2)
    (shift_jis latin-jisx0201 katakana-jisx0201 japanese-jisx0208)
Miles Bader's avatar
Miles Bader committed
761 762 763 764 765 766 767 768 769 770 771
    ,(cond ((fboundp 'unicode-precedence-list)
	    (cons 'utf-8 (delq 'ascii (mapcar 'charset-name
					      (unicode-precedence-list)))))
	   ((or (not (fboundp 'charsetp)) ;; non-Mule case
		(charsetp 'unicode-a)
		(not (mm-coding-system-p 'mule-utf-8)))
	    '(utf-8 unicode-a unicode-b unicode-c unicode-d unicode-e))
	   (t ;; If we have utf-8 we're in Mule 5+.
	    (append '(utf-8)
		    (delete 'ascii
			    (coding-system-get 'mule-utf-8 'safe-charsets))))))
772 773
  "Alist of MIME-charset/MULE-charsets.")

774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802
(defun mm-enrich-utf-8-by-mule-ucs ()
  "Make the `utf-8' MIME charset usable by the Mule-UCS package.
This function will run when the `un-define' module is loaded under
XEmacs, and fill the `utf-8' entry in `mm-mime-mule-charset-alist'
with Mule charsets.  It is completely useless for Emacs."
  (when (boundp 'unicode-basic-translation-charset-order-list)
    (condition-case nil
	(let ((val (delq
		    'ascii
		    (copy-sequence
		     (symbol-value
		      'unicode-basic-translation-charset-order-list))))
	      (elem (assq 'utf-8 mm-mime-mule-charset-alist)))
	  (if elem
	      (setcdr elem val)
	    (setq mm-mime-mule-charset-alist
		  (nconc mm-mime-mule-charset-alist
			 (list (cons 'utf-8 val))))))
      (error))))

;; Correct by construction, but should be unnecessary for Emacs:
(if (featurep 'xemacs)
    (eval-after-load "un-define" '(mm-enrich-utf-8-by-mule-ucs))
  (when (and (fboundp 'coding-system-list)
	     (fboundp 'sort-coding-systems))
    (let ((css (sort-coding-systems (coding-system-list 'base-only)))
	  cs mime mule alist)
      (while css
	(setq cs (pop css)
803
	      mime (or (coding-system-get cs :mime-charset); Emacs 23 (unicode)
804 805 806 807 808 809 810
		       (coding-system-get cs 'mime-charset)))
	(when (and mime
		   (not (eq t (setq mule
				    (coding-system-get cs 'safe-charsets))))
		   (not (assq mime alist)))
	  (push (cons mime (delq 'ascii mule)) alist)))
      (setq mm-mime-mule-charset-alist (nreverse alist)))))
811

812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841
(defvar mm-hack-charsets '(iso-8859-15 iso-2022-jp-2)
  "A list of special charsets.
Valid elements include:
`iso-8859-15'    convert ISO-8859-1, -9 to ISO-8859-15 if ISO-8859-15 exists.
`iso-2022-jp-2'  convert ISO-2022-jp to ISO-2022-jp-2 if ISO-2022-jp-2 exists."
)

(defvar mm-iso-8859-15-compatible
  '((iso-8859-1 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE")
    (iso-8859-9 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE\xD0\xDD\xDE\xF0\xFD\xFE"))
  "ISO-8859-15 exchangeable coding systems and inconvertible characters.")

(defvar mm-iso-8859-x-to-15-table
  (and (fboundp 'coding-system-p)
       (mm-coding-system-p 'iso-8859-15)
       (mapcar
	(lambda (cs)
	  (if (mm-coding-system-p (car cs))
	      (let ((c (string-to-char
			(decode-coding-string "\341" (car cs)))))
		(cons (char-charset c)
		      (cons
		       (- (string-to-char
			   (decode-coding-string "\341" 'iso-8859-15)) c)
		       (string-to-list (decode-coding-string (car (cdr cs))
							     (car cs))))))
	    '(gnus-charset 0)))
	mm-iso-8859-15-compatible))
  "A table of the difference character between ISO-8859-X and ISO-8859-15.")

842
(defcustom mm-coding-system-priorities
Miles Bader's avatar
Miles Bader committed
843 844 845 846 847 848 849 850 851 852
  (let ((lang (if (boundp 'current-language-environment)
		  (symbol-value 'current-language-environment))))
    (cond (;; XEmacs without Mule but with `file-coding'.
	   (not lang) nil)
	  ;; In XEmacs 21.5 it may be the one like "Japanese (UTF-8)".
	  ((string-match "\\`Japanese" lang)
	   ;; Japanese users prefer iso-2022-jp to euc-japan or
	   ;; shift_jis, however iso-8859-1 should be used when
	   ;; there are only ASCII text and Latin-1 characters.
	   '(iso-8859-1 iso-2022-jp iso-2022-jp-2 shift_jis utf-8))))
853 854 855 856 857 858
  "Preferred coding systems for encoding outgoing messages.

More than one suitable coding system may be found for some text.
By default, the coding system with the highest priority is used
to encode outgoing messages (see `sort-coding-systems').  If this
variable is set, it overrides the default priority."
859
  :version "21.2"
860 861 862 863
  :type '(repeat (symbol :tag "Coding system"))
  :group 'mime)

;; ??
864 865
(defvar mm-use-find-coding-systems-region
  (fboundp 'find-coding-systems-region)
866 867 868 869
  "Use `find-coding-systems-region' to find proper coding systems.

Setting it to nil is useful on Emacsen supporting Unicode if sending
mail with multiple parts is preferred to sending a Unicode one.")
870

Gerd Moellmann's avatar
Gerd Moellmann committed
871 872 873 874 875
;;; Internal variables:

;;; Functions:

(defun mm-mule-charset-to-mime-charset (charset)
Dave Love's avatar
Dave Love committed
876
  "Return the MIME charset corresponding to the given Mule CHARSET."
877 878
  (if (and (fboundp 'find-coding-systems-for-charsets)
	   (fboundp 'sort-coding-systems))
879 880 881 882 883 884 885 886 887
      (let ((css (sort (sort-coding-systems
			(find-coding-systems-for-charsets (list charset)))
		       'mm-sort-coding-systems-predicate))
	    cs mime)
	(while (and (not mime)
		    css)
	  (when (setq cs (pop css))
	    (setq mime (or (coding-system-get cs :mime-charset)
			   (coding-system-get cs 'mime-charset)))))
888
	mime)
889 890 891 892
    (let ((alist (mapcar (lambda (cs)
			   (assq cs mm-mime-mule-charset-alist))
			 (sort (mapcar 'car mm-mime-mule-charset-alist)
			       'mm-sort-coding-systems-predicate)))
893 894 895 896 897 898 899
	  out)
      (while alist
	(when (memq charset (cdar alist))
	  (setq out (caar alist)
		alist nil))
	(pop alist))
      out)))
Gerd Moellmann's avatar
Gerd Moellmann committed
900

901 902 903 904 905
(eval-and-compile
  (defvar mm-emacs-mule (and (not (featurep 'xemacs))
			     (boundp 'default-enable-multibyte-characters)
			     default-enable-multibyte-characters
			     (fboundp 'set-buffer-multibyte))
906
    "True in Emacs with Mule.")
907 908 909 910

  (if mm-emacs-mule
      (defun mm-enable-multibyte ()
	"Set the multibyte flag of the current buffer.
Dave Love's avatar
Dave Love committed
911 912
Only do this if the default value of `enable-multibyte-characters' is
non-nil.  This is a no-op in XEmacs."
913
	(set-buffer-multibyte 'to))
914
    (defalias 'mm-enable-multibyte 'ignore))
Gerd Moellmann's avatar
Gerd Moellmann committed
915

916 917 918
  (if mm-emacs-mule
      (defun mm-disable-multibyte ()
	"Unset the multibyte flag of in the current buffer.
Dave Love's avatar
Dave Love committed
919
This is a no-op in XEmacs."
920
	(set-buffer-multibyte nil))
921
    (defalias 'mm-disable-multibyte 'ignore)))
922

Gerd Moellmann's avatar
Gerd Moellmann committed
923 924
(defun mm-preferred-coding-system (charset)
  ;; A typo in some Emacs versions.
925 926
  (or (get-charset-property charset 'preferred-coding-system)
      (get-charset-property charset 'prefered-coding-system)))
Gerd Moellmann's avatar
Gerd Moellmann committed
927

928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948
;; Mule charsets shouldn't be used.
(defsubst mm-guess-charset ()
  "Guess Mule charset from the language environment."
  (or
   mail-parse-mule-charset ;; cached mule-charset
   (progn
     (setq mail-parse-mule-charset
	   (and (boundp 'current-language-environment)
		(car (last
		      (assq 'charset
			    (assoc current-language-environment
				   language-info-alist))))))
     (if (or (not mail-parse-mule-charset)
	     (eq mail-parse-mule-charset 'ascii))
	 (setq mail-parse-mule-charset
	       (or (car (last (assq mail-parse-charset
				    mm-mime-mule-charset-alist)))
		   ;; default
		   'latin-iso8859-1)))
     mail-parse-mule-charset)))

Gerd Moellmann's avatar
Gerd Moellmann committed
949 950 951 952 953
(defun mm-charset-after (&optional pos)
  "Return charset of a character in current buffer at position POS.
If POS is nil, it defauls to the current point.
If POS is out of range, the value is nil.
If the charset is `composition', return the actual one."
954 955 956 957 958
  (let ((char (char-after pos)) charset)
    (if (< (mm-char-int char) 128)
	(setq charset 'ascii)
      ;; charset-after is fake in some Emacsen.
      (setq charset (and (fboundp 'char-charset) (char-charset char)))
959
      (if (eq charset 'composition)	; Mule 4
960 961 962 963 964
	  (let ((p (or pos (point))))
	    (cadr (find-charset-region p (1+ p))))
	(if (and charset (not (memq charset '(ascii eight-bit-control
						    eight-bit-graphic))))
	    charset
965
	  (mm-guess-charset))))))
Gerd Moellmann's avatar
Gerd Moellmann committed
966 967

(defun mm-mime-charset (charset)
Dave Love's avatar
Dave Love committed
968
  "Return the MIME charset corresponding to the given Mule CHARSET."
969 970
  (if (eq charset 'unknown)
      (error "The message contains non-printable characters, please use attachment"))
971
  (if (and (fboundp 'coding-system-get) (fboundp 'get-charset-property))
Gerd Moellmann's avatar
Gerd Moellmann committed
972 973 974
      ;; This exists in Emacs 20.
      (or
       (and (mm-preferred-coding-system charset)
975 976 977 978
	    (or (coding-system-get
		 (mm-preferred-coding-system charset) :mime-charset)
		(coding-system-get
		 (mm-preferred-coding-system charset) 'mime-charset)))
Gerd Moellmann's avatar
Gerd Moellmann committed
979 980
       (and (eq charset 'ascii)
	    'us-ascii)
981
       (mm-preferred-coding-system charset)
Gerd Moellmann's avatar
Gerd Moellmann committed
982 983 984 985
       (mm-mule-charset-to-mime-charset charset))
    ;; This is for XEmacs.
    (mm-mule-charset-to-mime-charset charset)))

986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000
(if (fboundp 'delete-dups)
    (defalias 'mm-delete-duplicates 'delete-dups)
  (defun mm-delete-duplicates (list)
    "Destructively remove `equal' duplicates from LIST.
Store the result in LIST and return it.  LIST must be a proper list.
Of several `equal' occurrences of an element in LIST, the first
one is kept.

This is a compatibility function for Emacsen without `delete-dups'."
    ;; Code from `subr.el' in Emacs 22:
    (let ((tail list))
      (while tail
	(setcdr tail (delete (car tail) (cdr tail)))
	(setq tail (cdr tail))))
    list))
Gerd Moellmann's avatar
Gerd Moellmann committed
1001

1002 1003 1004
;; Fixme:  This is used in places when it should be testing the
;; default multibyteness.  See mm-default-multibyte-p.
(eval-and-compile
1005 1006
  (if (and (not (featurep 'xemacs))
	   (boundp 'enable-multibyte-characters))
1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018
      (defun mm-multibyte-p ()
	"Non-nil if multibyte is enabled in the current buffer."
	enable-multibyte-characters)
    (defun mm-multibyte-p () (featurep 'mule))))

(defun mm-default-multibyte-p ()
  "Return non-nil if the session is multibyte.
This affects whether coding conversion should be attempted generally."
  (if (featurep 'mule)
      (if (boundp 'default-enable-multibyte-characters)
	  default-enable-multibyte-characters
	t)))
Gerd Moellmann's avatar
Gerd Moellmann committed
1019

1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040
(defun mm-iso-8859-x-to-15-region (&optional b e)
  (if (fboundp 'char-charset)
      (let (charset item c inconvertible)
	(save-restriction
	  (if e (narrow-to-region b e))
	  (goto-char (point-min))
	  (skip-chars-forward "\0-\177")
	  (while (not (eobp))
	    (cond
	     ((not (setq item (assq (char-charset (setq c (char-after)))
				    mm-iso-8859-x-to-15-table)))
	      (forward-char))
	     ((memq c (cdr (cdr item)))
	      (setq inconvertible t)
	      (forward-char))
	     (t
	      (insert-before-markers (prog1 (+ c (car (cdr item)))
				       (delete-char 1)))))
	    (skip-chars-forward "\0-\177")))
	(not inconvertible))))

1041
(defun mm-sort-coding-systems-predicate (a b)
1042 1043 1044
  (let ((priorities
	 (mapcar (lambda (cs)
		   ;; Note: invalid entries are dropped silently
1045
		   (and (setq cs (mm-coding-system-p cs))
1046 1047
			(coding-system-base cs)))
		 mm-coding-system-priorities)))
1048 1049 1050 1051 1052
    (and (setq a (mm-coding-system-p a))
	 (if (setq b (mm-coding-system-p b))
	     (> (length (memq (coding-system-base a) priorities))
		(length (memq (coding-system-base b) priorities)))
	   t))))
1053

1054 1055 1056 1057
(eval-when-compile
  (autoload 'latin-unity-massage-name "latin-unity")
  (autoload 'latin-unity-maybe-remap "latin-unity")
  (autoload 'latin-unity-representations-feasible-region "latin-unity")
Dan Nicolaescu's avatar
Dan Nicolaescu committed
1058 1059 1060 1061
  (autoload 'latin-unity-representations-present-region "latin-unity"))

(defvar latin-unity-coding-systems)
(defvar latin-unity-ucs-list)
1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084

(defun mm-xemacs-find-mime-charset-1 (begin end)
  "Determine which MIME charset to use to send region as message.
This uses the XEmacs-specific latin-unity package to better handle the
case where identical characters from diverse ISO-8859-? character sets
can be encoded using a single one of the corresponding coding systems.

It treats `mm-coding-system-priorities' as the list of preferred
coding systems; a useful example setting for this list in Western
Europe would be '(iso-8859-1 iso-8859-15 utf-8), which would default
to the very standard Latin 1 coding system, and only move to coding
systems that are less supported as is necessary to encode the
characters that exist in the buffer.

Latin Unity doesn't know about those non-ASCII Roman characters that
are available in various East Asian character sets.  As such, its
behavior if you have a JIS 0212 LATIN SMALL LETTER A WITH ACUTE in a
buffer and it can otherwise be encoded as Latin 1, won't be ideal.
But this is very much a corner case, so don't worry about it."
  (let ((systems mm-coding-system-priorities) csets psets curset)

    ;; Load the Latin Unity library, if available.
    (when (and (not (featurep 'latin-unity)) (locate-library "latin-unity"))
1085
      (require 'latin-unity))
1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129

    ;; Now, can we use it?
    (if (featurep 'latin-unity)
	(progn
	  (setq csets (latin-unity-representations-feasible-region begin end)
		psets (latin-unity-representations-present-region begin end))

	  (catch 'done

	    ;; Pass back the first coding system in the preferred list
	    ;; that can encode the whole region.
	    (dolist (curset systems)
	      (setq curset (latin-unity-massage-name 'buffer-default curset))

	      ;; If the coding system is a universal coding system, then
	      ;; it can certainly encode all the characters in the region.
	      (if (memq curset latin-unity-ucs-list)
		  (throw 'done (list curset)))

	      ;; If a coding system isn't universal, and isn't in
	      ;; the list that latin unity knows about, we can't
	      ;; decide whether to use it here. Leave that until later
	      ;; in `mm-find-mime-charset-region' function, whence we
	      ;; have been called.
	      (unless (memq curset latin-unity-coding-systems)
		(throw 'done nil))

	      ;; Right, we know about this coding system, and it may
	      ;; conceivably be able to encode all the characters in
	      ;; the region.
	      (if (latin-unity-maybe-remap begin end curset csets psets t)
		  (throw 'done (list curset))))

	    ;; Can't encode using anything from the
	    ;; `mm-coding-system-priorities' list.
	    ;; Leave `mm-find-mime-charset' to do most of the work.
	    nil))

      ;; Right, latin unity isn't available; let `mm-find-charset-region'
      ;; take its default action, which equally applies to GNU Emacs.
      nil)))

(defmacro mm-xemacs-find-mime-charset (begin end)
  (when (featurep 'xemacs)
1130
    `(and (featurep 'mule) (mm-xemacs-find-mime-charset-1 ,begin ,end))))
1131

1132 1133
(declare-function mm-delete-duplicates "mm-util" (list))

1134
(defun mm-find-mime-charset-region (b e &optional hack-charsets)
1135
  "Return the MIME charsets needed to encode the region between B and E.
Pavel Janík's avatar
Pavel Janík committed
1136
nil means ASCII, a single-element list represents an appropriate MIME
1137
charset, and a longer list means no appropriate charset."
1138 1139 1140
  (let (charsets)
    ;; The return possibilities of this function are a mess...
    (or (and (mm-multibyte-p)
1141
	     mm-use-find-coding-systems-region
1142 1143 1144 1145
	     ;; Find the mime-charset of the most preferred coding
	     ;; system that has one.
	     (let ((systems (find-coding-systems-region b e)))
	       (when mm-coding-system-priorities
1146
		 (setq systems
1147 1148 1149 1150
		       (sort systems 'mm-sort-coding-systems-predicate)))
	       (setq systems (delq 'compound-text systems))
	       (unless (equal systems '(undecided))
		 (while systems
1151 1152 1153
		   (let* ((head (pop systems))
			  (cs (or (coding-system-get head :mime-charset)
				  (coding-system-get head 'mime-charset))))
1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171
		     ;; The mime-charset (`x-ctext') of
		     ;; `compound-text' is not in the IANA list.  We
		     ;; shouldn't normally use anything here with a
		     ;; mime-charset having an `x-' prefix.
		     ;; Fixme:  Allow this to be overridden, since
		     ;; there is existing use of x-ctext.
		     ;; Also people apparently need the coding system
		     ;; `iso-2022-jp-3' (which Mule-UCS defines with
		     ;; mime-charset, though it's not valid).
		     (if (and cs
			      (not (string-match "^[Xx]-" (symbol-name cs)))
			      ;; UTF-16 of any variety is invalid for
			      ;; text parts and, unfortunately, has
			      ;; mime-charset defined both in Mule-UCS
			      ;; and versions of Emacs.  (The name
			      ;; might be `mule-utf-16...'  or
			      ;; `utf-16...'.)
			      (not (string-match "utf-16" (symbol-name cs))))
1172 1173 1174
			 (setq systems nil
			       charsets (list cs))))))
	       charsets))
1175 1176 1177 1178 1179
	;; If we're XEmacs, and some coding system is appropriate,
	;; mm-xemacs-find-mime-charset will return an appropriate list.
	;; Otherwise, we'll get nil, and the next setq will get invoked.
	(setq charsets (mm-xemacs-find-mime-charset b e))

1180
	;; Fixme: won't work for unibyte Emacs 23:
1181

1182
	;; We're not multibyte, or a single coding system won't cover it.
1183
	(setq charsets
1184 1185 1186 1187
	      (mm-delete-duplicates
	       (mapcar 'mm-mime-charset
		       (delq 'ascii
			     (mm-find-charset-region b e))))))
1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207
    (if (and (> (length charsets) 1)
	     (memq 'iso-8859-15 charsets)
	     (memq 'iso-8859-15 hack-charsets)
	     (save-excursion (mm-iso-8859-x-to-15-region b e)))
	(dolist (x mm-iso-8859-15-compatible)
	  (setq charsets (delq (car x) charsets))))
    (if (and (memq 'iso-2022-jp-2 charsets)
	     (memq 'iso-2022-jp-2 hack-charsets))
	(setq charsets (delq 'iso-2022-jp charsets)))
    ;; Attempt to reduce the number of charsets if utf-8 is available.
    (if (and (featurep 'xemacs)
	     (> (length charsets) 1)
	     (mm-coding-system-p 'utf-8))
	(let ((mm-coding-system-priorities
	       (cons 'utf-8 mm-coding-system-priorities)))
	  (setq charsets
		(mm-delete-duplicates
		 (mapcar 'mm-mime-charset
			 (delq 'ascii
			       (mm-find-charset-region b e)))))))
1208
    charsets))
1209

Gerd Moellmann's avatar
Gerd Moellmann committed
1210 1211
(defmacro mm-with-unibyte-buffer (&rest forms)
  "Create a temporary buffer, and evaluate FORMS there like `progn'.
Dave Love's avatar
Dave Love committed
1212
Use unibyte mode for this."
1213 1214 1215
  `(with-temp-buffer
     (mm-disable-multibyte)
     ,@forms))
Gerd Moellmann's avatar
Gerd Moellmann committed
1216 1217 1218
(put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
(put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))

1219 1220 1221
(defmacro mm-with-multibyte-buffer (&rest forms)
  "Create a temporary buffer, and evaluate FORMS there like `progn'.
Use multibyte mode for this."
1222 1223 1224
  `(with-temp-buffer
     (mm-enable-multibyte)
     ,@forms))
1225 1226 1227
(put 'mm-with-multibyte-buffer 'lisp-indent-function 0)
(put 'mm-with-multibyte-buffer 'edebug-form-spec '(body))

Gerd Moellmann's avatar
Gerd Moellmann committed
1228
(defmacro mm-with-unibyte-current-buffer (&rest forms)
1229
  "Evaluate FORMS with current buffer temporarily made unibyte.
Dave Love's avatar
Dave Love committed
1230
Also bind `default-enable-multibyte-characters' to nil.
1231 1232 1233 1234 1235 1236
Equivalent to `progn' in XEmacs

NOTE: Use this macro with caution in multibyte buffers (it is not
worth using this macro in unibyte buffers of course).  Use of
`(set-buffer-multibyte t)', which is run finally, is generally
harmful since it is likely to modify existing data in the buffer.
1237 1238
For instance, it converts \"\\300\\255\" into \"\\255\" in
Emacs 23 (unicode)."
1239 1240
  (let ((multibyte (make-symbol "multibyte"))
	(buffer (make-symbol "buffer")))
1241
    `(if mm-emacs-mule
1242
	 (let ((,multibyte enable-multibyte-characters)
1243
	       (,buffer (current-buffer)))
Dave Love's avatar
Dave Love committed
1244 1245 1246 1247
	   (unwind-protect
	       (let (default-enable-multibyte-characters)
		 (set-buffer-multibyte nil)
		 ,@forms)
1248
	     (set-buffer ,buffer)
Dave Love's avatar
Dave Love committed
1249
	     (set-buffer-multibyte ,multibyte)))
1250
       (let (default-enable-multibyte-characters)
Dave Love's avatar
Dave Love committed
1251
	 ,@forms))))
Gerd Moellmann's avatar
Gerd Moellmann committed
1252 1253 1254 1255
(put 'mm-with-unibyte-current-buffer 'lisp-indent-function 0)
(put 'mm-with-unibyte-current-buffer 'edebug-form-spec '(body))

(defun mm-find-charset-region (b e)
Dave Love's avatar
Dave Love committed
1256
  "Return a list of Emacs charsets in the region B to E."
Gerd Moellmann's avatar
Gerd Moellmann committed
1257 1258
  (cond
   ((and (mm-multibyte-p)
1259
	 (fboundp 'find-charset-region))
Gerd Moellmann's avatar
Gerd Moellmann committed
1260
    ;; Remove composition since the base charsets have been included.