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, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005 Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (eval-when-compile (require 'cl))
  30 (require 'mail-prsvr)
  31
  32 (eval-and-compile
  33   (mapcar
  34    (lambda (elem)
  35      (let ((nfunc (intern (format "mm-%s" (car elem)))))
  36        (if (fboundp (car elem))
  37            (defalias nfunc (car elem))
  38          (defalias nfunc (cdr elem)))))
  39    '((decode-coding-string . (lambda (s a) s))
  40      (encode-coding-string . (lambda (s a) s))
  41      (encode-coding-region . ignore)
  42      (coding-system-list . ignore)
  43      (decode-coding-region . ignore)
  44      (char-int . identity)
  45      (coding-system-equal . equal)
  46      (annotationp . ignore)
  47      (set-buffer-file-coding-system . ignore)
  48      (read-charset
  49       . (lambda (prompt)
  50           "Return a charset."
  51           (intern
  52            (completing-read
  53             prompt
  54             (mapcar (lambda (e) (list (symbol-name (car e))))
  55                     mm-mime-mule-charset-alist)
  56             nil t))))
  57      (subst-char-in-string
  58       . (lambda (from to string &optional inplace)
  59           ;; stolen (and renamed) from nnheader.el
  60           "Replace characters in STRING from FROM to TO.
  61           Unless optional argument INPLACE is non-nil, return a new string."
  62           (let ((string (if inplace string (copy-sequence string)))
  63                 (len (length string))
  64                 (idx 0))
  65             ;; Replace all occurrences of FROM with TO.
  66             (while (< idx len)
  67               (when (= (aref string idx) from)
  68                 (aset string idx to))
  69               (setq idx (1+ idx)))
  70             string)))
  71      (replace-in-string
  72       . (lambda (string regexp rep &optional literal)
  73           "See `replace-regexp-in-string', only the order of args differs."
  74           (replace-regexp-in-string regexp rep string nil literal)))
  75      (string-as-unibyte . identity)
  76      (string-make-unibyte . identity)
  77      ;; string-as-multibyte often doesn't really do what you think it does.
  78      ;; Example:
  79      ;;    (aref (string-as-multibyte "\201") 0) -> 129 (aka ?\201)
  80      ;;    (aref (string-as-multibyte "\300") 0) -> 192 (aka ?\300)
  81      ;;    (aref (string-as-multibyte "\300\201") 0) -> 192 (aka ?\300)
  82      ;;    (aref (string-as-multibyte "\300\201") 1) -> 129 (aka ?\201)
  83      ;; but
  84      ;;    (aref (string-as-multibyte "\201\300") 0) -> 2240
  85      ;;    (aref (string-as-multibyte "\201\300") 1) -> <error>
  86      ;; Better use string-to-multibyte or encode-coding-string.
  87      ;; If you really need string-as-multibyte somewhere it's usually
  88      ;; because you're using the internal emacs-mule representation (maybe
  89      ;; because you're using string-as-unibyte somewhere), which is
  90      ;; generally a problem in itself.
  91      ;; Here is an approximate equivalence table to help think about it:
  92      ;; (string-as-multibyte s)   ~= (decode-coding-string s 'emacs-mule)
  93      ;; (string-to-multibyte s)   ~= (decode-coding-string s 'binary)
  94      ;; (string-make-multibyte s) ~= (decode-coding-string s locale-coding-system)
  95      (string-as-multibyte . identity)
  96      (string-to-multibyte
  97       . (lambda (string)
  98           "Return a multibyte string with the same individual chars as string."
  99           (mapconcat
 100            (lambda (ch) (mm-string-as-multibyte (char-to-string ch)))
 101            string "")))
 102      (multibyte-string-p . ignore)
 103      ;; It is not a MIME function, but some MIME functions use it.
 104      (make-temp-file . (lambda (prefix &optional dir-flag)
 105                          (let ((file (expand-file-name
 106                                       (make-temp-name prefix)
 107                                       (if (fboundp 'temp-directory)
 108                                           (temp-directory)
 109                                         temporary-file-directory))))
 110                            (if dir-flag
 111                                (make-directory file))
 112                            file)))
 113      (insert-byte . insert-char)
 114      (multibyte-char-to-unibyte . identity))))
 115
 116 (eval-and-compile
 117   (defalias 'mm-char-or-char-int-p
 118     (cond
 119      ((fboundp 'char-or-char-int-p) 'char-or-char-int-p)
 120      ((fboundp 'char-valid-p) 'char-valid-p)
 121      (t 'identity))))
 122
 123 ;; Fixme:  This seems always to be used to read a MIME charset, so it
 124 ;; should be re-named and fixed (in Emacs) to offer completion only on
 125 ;; proper charset names (base coding systems which have a
 126 ;; mime-charset defined).  XEmacs doesn't believe in mime-charset;
 127 ;; test with
 128 ;;   `(or (coding-system-get 'iso-8859-1 'mime-charset)
 129 ;;        (coding-system-get 'iso-8859-1 :mime-charset))'
 130 ;; Actually, there should be an `mm-coding-system-mime-charset'.
 131 (eval-and-compile
 132   (defalias 'mm-read-coding-system
 133     (cond
 134      ((fboundp 'read-coding-system)
 135       (if (and (featurep 'xemacs)
 136                (<= (string-to-number emacs-version) 21.1))
 137           (lambda (prompt &optional default-coding-system)
 138             (read-coding-system prompt))
 139         'read-coding-system))
 140      (t (lambda (prompt &optional default-coding-system)
 141           "Prompt the user for a coding system."
 142           (completing-read
 143            prompt (mapcar (lambda (s) (list (symbol-name (car s))))
 144                           mm-mime-mule-charset-alist)))))))
 145
 146 (defvar mm-coding-system-list nil)
 147 (defun mm-get-coding-system-list ()
 148   "Get the coding system list."
 149   (or mm-coding-system-list
 150       (setq mm-coding-system-list (mm-coding-system-list))))
 151
 152 (defun mm-coding-system-p (cs)
 153   "Return non-nil if CS is a symbol naming a coding system.
 154 In XEmacs, also return non-nil if CS is a coding system object.
 155 If CS is available, return CS itself in Emacs, and return a coding
 156 system object in XEmacs."
 157   (if (fboundp 'find-coding-system)
 158       (and cs (find-coding-system cs))
 159     (if (fboundp 'coding-system-p)
 160         (when (coding-system-p cs)
 161           cs)
 162       ;; Is this branch ever actually useful?
 163       (car (memq cs (mm-get-coding-system-list))))))
 164
 165 (defvar mm-charset-synonym-alist
 166   `(
 167     ;; Not in XEmacs, but it's not a proper MIME charset anyhow.
 168     ,@(unless (mm-coding-system-p 'x-ctext)
 169        '((x-ctext . ctext)))
 170     ;; ISO-8859-15 is very similar to ISO-8859-1.  But it's _different_!
 171     ,@(unless (mm-coding-system-p 'iso-8859-15)
 172        '((iso-8859-15 . iso-8859-1)))
 173     ;; BIG-5HKSCS is similar to, but different than, BIG-5.
 174     ,@(unless (mm-coding-system-p 'big5-hkscs)
 175         '((big5-hkscs . big5)))
 176     ;; Windows-1252 is actually a superset of Latin-1.  See also
 177     ;; `gnus-article-dumbquotes-map'.
 178     ,@(unless (mm-coding-system-p 'windows-1252)
 179        (if (mm-coding-system-p 'cp1252)
 180            '((windows-1252 . cp1252))
 181          '((windows-1252 . iso-8859-1))))
 182     ;; Windows-1250 is a variant of Latin-2 heavily used by Microsoft
 183     ;; Outlook users in Czech republic. Use this to allow reading of their
 184     ;; e-mails. cp1250 should be defined by M-x codepage-setup.
 185     ,@(if (and (not (mm-coding-system-p 'windows-1250))
 186                (mm-coding-system-p 'cp1250))
 187           '((windows-1250 . cp1250)))
 188     ;; A Microsoft misunderstanding.
 189     ,@(if (and (not (mm-coding-system-p 'unicode))
 190                (mm-coding-system-p 'utf-16-le))
 191           '((unicode . utf-16-le)))
 192     ;; A Microsoft misunderstanding.
 193     ,@(unless (mm-coding-system-p 'ks_c_5601-1987)
 194         (if (mm-coding-system-p 'cp949)
 195             '((ks_c_5601-1987 . cp949))
 196           '((ks_c_5601-1987 . euc-kr))))
 197     )
 198   "A mapping from invalid charset names to the real charset names.")
 199
 200 (defvar mm-binary-coding-system
 201   (cond
 202    ((mm-coding-system-p 'binary) 'binary)
 203    ((mm-coding-system-p 'no-conversion) 'no-conversion)
 204    (t nil))
 205   "100% binary coding system.")
 206
 207 (defvar mm-text-coding-system
 208   (or (if (memq system-type '(windows-nt ms-dos ms-windows))
 209           (and (mm-coding-system-p 'raw-text-dos) 'raw-text-dos)
 210         (and (mm-coding-system-p 'raw-text) 'raw-text))
 211       mm-binary-coding-system)
 212   "Text-safe coding system (For removing ^M).")
 213
 214 (defvar mm-text-coding-system-for-write nil
 215   "Text coding system for write.")
 216
 217 (defvar mm-auto-save-coding-system
 218   (cond
 219    ((mm-coding-system-p 'utf-8-emacs)   ; Mule 7
 220     (if (memq system-type '(windows-nt ms-dos ms-windows))
 221         (if (mm-coding-system-p 'utf-8-emacs-dos)
 222             'utf-8-emacs-dos mm-binary-coding-system)
 223       'utf-8-emacs))
 224    ((mm-coding-system-p 'emacs-mule)
 225     (if (memq system-type '(windows-nt ms-dos ms-windows))
 226         (if (mm-coding-system-p 'emacs-mule-dos)
 227             'emacs-mule-dos mm-binary-coding-system)
 228       'emacs-mule))
 229    ((mm-coding-system-p 'escape-quoted) 'escape-quoted)
 230    (t mm-binary-coding-system))
 231   "Coding system of auto save file.")
 232
 233 (defvar mm-universal-coding-system mm-auto-save-coding-system
 234   "The universal coding system.")
 235
 236 ;; Fixme: some of the cars here aren't valid MIME charsets.  That
 237 ;; should only matter with XEmacs, though.
 238 (defvar mm-mime-mule-charset-alist
 239   `((us-ascii ascii)
 240     (iso-8859-1 latin-iso8859-1)
 241     (iso-8859-2 latin-iso8859-2)
 242     (iso-8859-3 latin-iso8859-3)
 243     (iso-8859-4 latin-iso8859-4)
 244     (iso-8859-5 cyrillic-iso8859-5)
 245     ;; Non-mule (X)Emacs uses the last mule-charset for 8bit characters.
 246     ;; The fake mule-charset, gnus-koi8-r, tells Gnus that the default
 247     ;; charset is koi8-r, not iso-8859-5.
 248     (koi8-r cyrillic-iso8859-5 gnus-koi8-r)
 249     (iso-8859-6 arabic-iso8859-6)
 250     (iso-8859-7 greek-iso8859-7)
 251     (iso-8859-8 hebrew-iso8859-8)
 252     (iso-8859-9 latin-iso8859-9)
 253     (iso-8859-14 latin-iso8859-14)
 254     (iso-8859-15 latin-iso8859-15)
 255     (viscii vietnamese-viscii-lower)
 256     (iso-2022-jp latin-jisx0201 japanese-jisx0208 japanese-jisx0208-1978)
 257     (euc-kr korean-ksc5601)
 258     (gb2312 chinese-gb2312)
 259     (big5 chinese-big5-1 chinese-big5-2)
 260     (tibetan tibetan)
 261     (thai-tis620 thai-tis620)
 262     (windows-1251 cyrillic-iso8859-5)
 263     (iso-2022-7bit ethiopic arabic-1-column arabic-2-column)
 264     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
 265                    latin-jisx0201 japanese-jisx0208-1978
 266                    chinese-gb2312 japanese-jisx0208
 267                    korean-ksc5601 japanese-jisx0212)
 268     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
 269                     latin-jisx0201 japanese-jisx0208-1978
 270                     chinese-gb2312 japanese-jisx0208
 271                     korean-ksc5601 japanese-jisx0212
 272                     chinese-cns11643-1 chinese-cns11643-2)
 273     (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
 274                     cyrillic-iso8859-5 greek-iso8859-7
 275                     latin-jisx0201 japanese-jisx0208-1978
 276                     chinese-gb2312 japanese-jisx0208
 277                     korean-ksc5601 japanese-jisx0212
 278                     chinese-cns11643-1 chinese-cns11643-2
 279                     chinese-cns11643-3 chinese-cns11643-4
 280                     chinese-cns11643-5 chinese-cns11643-6
 281                     chinese-cns11643-7)
 282     (iso-2022-jp-3 latin-jisx0201 japanese-jisx0208-1978 japanese-jisx0208
 283                    japanese-jisx0213-1 japanese-jisx0213-2)
 284     (shift_jis latin-jisx0201 katakana-jisx0201 japanese-jisx0208)
 285     ,(if (or (not (fboundp 'charsetp)) ;; non-Mule case
 286              (charsetp 'unicode-a)
 287              (not (mm-coding-system-p 'mule-utf-8)))
 288          '(utf-8 unicode-a unicode-b unicode-c unicode-d unicode-e)
 289        ;; If we have utf-8 we're in Mule 5+.
 290        (append '(utf-8)
 291                (delete 'ascii
 292                        (coding-system-get 'mule-utf-8 'safe-charsets)))))
 293   "Alist of MIME-charset/MULE-charsets.")
 294
 295 (defun mm-enrich-utf-8-by-mule-ucs ()
 296   "Make the `utf-8' MIME charset usable by the Mule-UCS package.
 297 This function will run when the `un-define' module is loaded under
 298 XEmacs, and fill the `utf-8' entry in `mm-mime-mule-charset-alist'
 299 with Mule charsets.  It is completely useless for Emacs."
 300   (unless (cdr (delete '(mm-enrich-utf-8-by-mule-ucs)
 301                        (assoc "un-define" after-load-alist)))
 302     (setq after-load-alist
 303           (delete '("un-define") after-load-alist)))
 304   (when (boundp 'unicode-basic-translation-charset-order-list)
 305     (condition-case nil
 306         (let ((val (delq
 307                     'ascii
 308                     (copy-sequence
 309                      (symbol-value
 310                       'unicode-basic-translation-charset-order-list))))
 311               (elem (assq 'utf-8 mm-mime-mule-charset-alist)))
 312           (if elem
 313               (setcdr elem val)
 314             (setq mm-mime-mule-charset-alist
 315                   (nconc mm-mime-mule-charset-alist
 316                          (list (cons 'utf-8 val))))))
 317       (error))))
 318
 319 ;; Correct by construction, but should be unnecessary for Emacs:
 320 (if (featurep 'xemacs)
 321     (eval-after-load "un-define" '(mm-enrich-utf-8-by-mule-ucs))
 322   (when (and (fboundp 'coding-system-list)
 323              (fboundp 'sort-coding-systems))
 324     (let ((css (sort-coding-systems (coding-system-list 'base-only)))
 325           cs mime mule alist)
 326       (while css
 327         (setq cs (pop css)
 328               mime (or (coding-system-get cs :mime-charset) ; Emacs 22
 329                        (coding-system-get cs 'mime-charset)))
 330         (when (and mime
 331                    (not (eq t (setq mule
 332                                     (coding-system-get cs 'safe-charsets))))
 333                    (not (assq mime alist)))
 334           (push (cons mime (delq 'ascii mule)) alist)))
 335       (setq mm-mime-mule-charset-alist (nreverse alist)))))
 336
 337 (defvar mm-hack-charsets '(iso-8859-15 iso-2022-jp-2)
 338   "A list of special charsets.
 339 Valid elements include:
 340 `iso-8859-15'    convert ISO-8859-1, -9 to ISO-8859-15 if ISO-8859-15 exists.
 341 `iso-2022-jp-2'  convert ISO-2022-jp to ISO-2022-jp-2 if ISO-2022-jp-2 exists."
 342 )
 343
 344 (defvar mm-iso-8859-15-compatible
 345   '((iso-8859-1 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE")
 346     (iso-8859-9 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE\xD0\xDD\xDE\xF0\xFD\xFE"))
 347   "ISO-8859-15 exchangeable coding systems and inconvertible characters.")
 348
 349 (defvar mm-iso-8859-x-to-15-table
 350   (and (fboundp 'coding-system-p)
 351        (mm-coding-system-p 'iso-8859-15)
 352        (mapcar
 353         (lambda (cs)
 354           (if (mm-coding-system-p (car cs))
 355               (let ((c (string-to-char
 356                         (decode-coding-string "\341" (car cs)))))
 357                 (cons (char-charset c)
 358                       (cons
 359                        (- (string-to-char
 360                            (decode-coding-string "\341" 'iso-8859-15)) c)
 361                        (string-to-list (decode-coding-string (car (cdr cs))
 362                                                              (car cs))))))
 363             '(gnus-charset 0)))
 364         mm-iso-8859-15-compatible))
 365   "A table of the difference character between ISO-8859-X and ISO-8859-15.")
 366
 367 (defcustom mm-coding-system-priorities
 368   (if (boundp 'current-language-environment)
 369       (let ((lang (symbol-value 'current-language-environment)))
 370         (cond ((string= lang "Japanese")
 371                ;; Japanese users prefer iso-2022-jp to euc-japan or
 372                ;; shift_jis, however iso-8859-1 should be used when
 373                ;; there are only ASCII text and Latin-1 characters.
 374                '(iso-8859-1 iso-2022-jp iso-2022-jp-2 shift_jis utf-8)))))
 375   "Preferred coding systems for encoding outgoing messages.
 376
 377 More than one suitable coding system may be found for some text.
 378 By default, the coding system with the highest priority is used
 379 to encode outgoing messages (see `sort-coding-systems').  If this
 380 variable is set, it overrides the default priority."
 381   :version "21.2"
 382   :type '(repeat (symbol :tag "Coding system"))
 383   :group 'mime)
 384
 385 ;; ??
 386 (defvar mm-use-find-coding-systems-region
 387   (fboundp 'find-coding-systems-region)
 388   "Use `find-coding-systems-region' to find proper coding systems.
 389
 390 Setting it to nil is useful on Emacsen supporting Unicode if sending
 391 mail with multiple parts is preferred to sending a Unicode one.")
 392
 393 ;;; Internal variables:
 394
 395 ;;; Functions:
 396
 397 (defun mm-mule-charset-to-mime-charset (charset)
 398   "Return the MIME charset corresponding to the given Mule CHARSET."
 399   (if (and (fboundp 'find-coding-systems-for-charsets)
 400            (fboundp 'sort-coding-systems))
 401       (let ((css (sort (sort-coding-systems
 402                         (find-coding-systems-for-charsets (list charset)))
 403                        'mm-sort-coding-systems-predicate))
 404             cs mime)
 405         (while (and (not mime)
 406                     css)
 407           (when (setq cs (pop css))
 408             (setq mime (or (coding-system-get cs :mime-charset)
 409                            (coding-system-get cs 'mime-charset)))))
 410         mime)
 411     (let ((alist (mapcar (lambda (cs)
 412                            (assq cs mm-mime-mule-charset-alist))
 413                          (sort (mapcar 'car mm-mime-mule-charset-alist)
 414                                'mm-sort-coding-systems-predicate)))
 415           out)
 416       (while alist
 417         (when (memq charset (cdar alist))
 418           (setq out (caar alist)
 419                 alist nil))
 420         (pop alist))
 421       out)))
 422
 423 (defun mm-charset-to-coding-system (charset &optional lbt)
 424   "Return coding-system corresponding to CHARSET.
 425 CHARSET is a symbol naming a MIME charset.
 426 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
 427 used as the line break code type of the coding system."
 428   (when (stringp charset)
 429     (setq charset (intern (downcase charset))))
 430   (when lbt
 431     (setq charset (intern (format "%s-%s" charset lbt))))
 432   (cond
 433    ((null charset)
 434     charset)
 435    ;; Running in a non-MULE environment.
 436    ((or (null (mm-get-coding-system-list))
 437         (not (fboundp 'coding-system-get)))
 438     charset)
 439    ;; ascii
 440    ((eq charset 'us-ascii)
 441     'ascii)
 442    ;; Check to see whether we can handle this charset.  (This depends
 443    ;; on there being some coding system matching each `mime-charset'
 444    ;; property defined, as there should be.)
 445    ((and (mm-coding-system-p charset)
 446 ;;; Doing this would potentially weed out incorrect charsets.
 447 ;;;      charset
 448 ;;;      (eq charset (coding-system-get charset 'mime-charset))
 449          )
 450     charset)
 451    ;; Translate invalid charsets.
 452    ((let ((cs (cdr (assq charset mm-charset-synonym-alist))))