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-2015 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;;; Code:
  25
  26 (eval-when-compile (require 'cl))
  27 (require 'mail-prsvr)
  28
  29 (eval-and-compile
  30   (if (featurep 'xemacs)
  31       (unless (ignore-errors
  32                 (require 'timer-funcs))
  33         (require 'timer))
  34     (require 'timer)))
  35
  36 (defvar mm-mime-mule-charset-alist )
  37 ;; Note this is not presently used on Emacs >= 23, which is good,
  38 ;; since it means standalone message-mode (which requires mml and
  39 ;; hence mml-util) does not load gnus-util.
  40 (autoload 'gnus-completing-read "gnus-util")
  41
  42 ;; Emulate functions that are not available in every (X)Emacs version.
  43 ;; The name of a function is prefixed with mm-, like `mm-char-int' for
  44 ;; `char-int' that is a native XEmacs function, not available in Emacs.
  45 ;; Gnus programs all should use mm- functions, not the original ones.
  46 (eval-and-compile
  47   (mapc
  48    (lambda (elem)
  49      (let ((nfunc (intern (format "mm-%s" (car elem)))))
  50        (if (fboundp (car elem))
  51            (defalias nfunc (car elem))
  52          (defalias nfunc (cdr elem)))))
  53    `(;; `coding-system-list' is not available in XEmacs 21.4 built
  54      ;; without the `file-coding' feature.
  55      (coding-system-list . ignore)
  56      ;; `char-int' is an XEmacs function, not available in Emacs.
  57      (char-int . identity)
  58      ;; `coding-system-equal' is an Emacs function, not available in XEmacs.
  59      (coding-system-equal . equal)
  60      ;; `annotationp' is an XEmacs function, not available in Emacs.
  61      (annotationp . ignore)
  62      ;; `set-buffer-file-coding-system' is not available in XEmacs 21.4
  63      ;; built without the `file-coding' feature.
  64      (set-buffer-file-coding-system . ignore)
  65      ;; `read-charset' is an Emacs function, not available in XEmacs.
  66      (read-charset
  67       . ,(lambda (prompt)
  68            "Return a charset."
  69            (intern
  70             (gnus-completing-read
  71              prompt
  72              (mapcar (lambda (e) (symbol-name (car e)))
  73                      mm-mime-mule-charset-alist)
  74              t))))
  75      ;; `subst-char-in-string' is not available in XEmacs 21.4.
  76      (subst-char-in-string
  77       . ,(lambda (from to string &optional inplace)
  78            ;; stolen (and renamed) from nnheader.el
  79            "Replace characters in STRING from FROM to TO.
  80           Unless optional argument INPLACE is non-nil, return a new string."
  81            (let ((string (if inplace string (copy-sequence string)))
  82                  (len (length string))
  83                  (idx 0))
  84              ;; Replace all occurrences of FROM with TO.
  85              (while (< idx len)
  86                (when (= (aref string idx) from)
  87                  (aset string idx to))
  88                (setq idx (1+ idx)))
  89              string)))
  90      ;; `replace-in-string' is an XEmacs function, not available in Emacs.
  91      (replace-in-string
  92       . ,(lambda (string regexp rep &optional literal)
  93            "See `replace-regexp-in-string', only the order of args differs."
  94            (replace-regexp-in-string regexp rep string nil literal)))
  95      ;; `string-as-unibyte' is an Emacs function, not available in XEmacs.
  96      (string-as-unibyte . identity)
  97      ;; `string-make-unibyte' is an Emacs function, not available in XEmacs.
  98      (string-make-unibyte . identity)
  99      ;; string-as-multibyte often doesn't really do what you think it does.
 100      ;; Example:
 101      ;;    (aref (string-as-multibyte "\201") 0) -> 129 (aka ?\201)
 102      ;;    (aref (string-as-multibyte "\300") 0) -> 192 (aka ?\300)
 103      ;;    (aref (string-as-multibyte "\300\201") 0) -> 192 (aka ?\300)
 104      ;;    (aref (string-as-multibyte "\300\201") 1) -> 129 (aka ?\201)
 105      ;; but
 106      ;;    (aref (string-as-multibyte "\201\300") 0) -> 2240
 107      ;;    (aref (string-as-multibyte "\201\300") 1) -> <error>
 108      ;; Better use string-to-multibyte or encode-coding-string.
 109      ;; If you really need string-as-multibyte somewhere it's usually
 110      ;; because you're using the internal emacs-mule representation (maybe
 111      ;; because you're using string-as-unibyte somewhere), which is
 112      ;; generally a problem in itself.
 113      ;; Here is an approximate equivalence table to help think about it:
 114      ;; (string-as-multibyte s)   ~= (decode-coding-string s 'emacs-mule)
 115      ;; (string-to-multibyte s)   ~= (decode-coding-string s 'binary)
 116      ;; (string-make-multibyte s) ~= (decode-coding-string s locale-coding-system)
 117      ;; `string-as-multibyte' is an Emacs function, not available in XEmacs.
 118      (string-as-multibyte . identity)
 119      ;; `multibyte-string-p' is an Emacs function, not available in XEmacs.
 120      (multibyte-string-p . ignore)
 121      ;; `insert-byte' is available only in Emacs 23.1 or greater.
 122      (insert-byte . insert-char)
 123      ;; `multibyte-char-to-unibyte' is an Emacs function, not available
 124      ;; in XEmacs.
 125      (multibyte-char-to-unibyte . identity)
 126      ;; `set-buffer-multibyte' is an Emacs function, not available in XEmacs.
 127      (set-buffer-multibyte . ignore)
 128      ;; `substring-no-properties' is available only in Emacs 22.1 or greater.
 129      (substring-no-properties
 130       . ,(lambda (string &optional from to)
 131            "Return a substring of STRING, without text properties.
 132 It starts at index FROM and ending before TO.
 133 TO may be nil or omitted; then the substring runs to the end of STRING.
 134 If FROM is nil or omitted, the substring starts at the beginning of STRING.
 135 If FROM or TO is negative, it counts from the end.
 136
 137 With one argument, just copy STRING without its properties."
 138            (setq string (substring string (or from 0) to))
 139            (set-text-properties 0 (length string) nil string)
 140            string))
 141      ;; `line-number-at-pos' is available only in Emacs 22.1 or greater
 142      ;; and XEmacs 21.5.
 143      (line-number-at-pos
 144       . ,(lambda (&optional pos)
 145            "Return (narrowed) buffer line number at position POS.
 146 If POS is nil, use current buffer location.
 147 Counting starts at (point-min), so the value refers
 148 to the contents of the accessible portion of the buffer."
 149            (let ((opoint (or pos (point))) start)
 150              (save-excursion
 151                (goto-char (point-min))
 152                (setq start (point))
 153                (goto-char opoint)
 154                (forward-line 0)
 155                (1+ (count-lines start (point))))))))))
 156
 157 ;; `special-display-p' is an Emacs function, not available in XEmacs.
 158 (defalias 'mm-special-display-p
 159   (if (featurep 'emacs)
 160       'special-display-p
 161     (lambda (buffer-name)
 162       "Returns non-nil if a buffer named BUFFER-NAME gets a special frame."
 163       (and special-display-function
 164            (or (and (member buffer-name special-display-buffer-names) t)
 165                (cdr (assoc buffer-name special-display-buffer-names))
 166                (catch 'return
 167                  (dolist (elem special-display-regexps)
 168                    (and (stringp elem)
 169                         (string-match elem buffer-name)
 170                         (throw 'return t))
 171                    (and (consp elem)
 172                         (stringp (car elem))
 173                         (string-match (car elem) buffer-name)
 174                         (throw 'return (cdr elem))))))))))
 175
 176 ;; `decode-coding-string', `encode-coding-string', `decode-coding-region'
 177 ;; and `encode-coding-region' are available in Emacs and XEmacs built with
 178 ;; the `file-coding' feature, but the XEmacs versions treat nil, that is
 179 ;; given as the `coding-system' argument, as the `binary' coding system.
 180 (eval-and-compile
 181   (if (featurep 'xemacs)
 182       (if (featurep 'file-coding)
 183           (progn
 184             (defun mm-decode-coding-string (str coding-system)
 185               (if coding-system
 186                   (decode-coding-string str coding-system)
 187                 str))
 188             (defun mm-encode-coding-string (str coding-system)
 189               (if coding-system
 190                   (encode-coding-string str coding-system)
 191                 str))
 192             (defun mm-decode-coding-region (start end coding-system)
 193               (if coding-system
 194                   (decode-coding-region start end coding-system)))
 195             (defun mm-encode-coding-region (start end coding-system)
 196               (if coding-system
 197                   (encode-coding-region start end coding-system))))
 198         (defun mm-decode-coding-string (str coding-system) str)
 199         (defun mm-encode-coding-string (str coding-system) str)
 200         (defalias 'mm-decode-coding-region 'ignore)
 201         (defalias 'mm-encode-coding-region 'ignore))
 202     (defalias 'mm-decode-coding-string 'decode-coding-string)
 203     (defalias 'mm-encode-coding-string 'encode-coding-string)
 204     (defalias 'mm-decode-coding-region 'decode-coding-region)
 205     (defalias 'mm-encode-coding-region 'encode-coding-region)))
 206
 207 ;; `string-to-multibyte' is available only in Emacs.
 208 (defalias 'mm-string-to-multibyte (if (featurep 'xemacs)
 209                                       'identity
 210                                     'string-to-multibyte))
 211
 212 ;; `char-or-char-int-p' is an XEmacs function, not available in Emacs.
 213 (eval-and-compile
 214   (defalias 'mm-char-or-char-int-p
 215     (cond
 216      ((fboundp 'char-or-char-int-p) 'char-or-char-int-p)
 217      ((fboundp 'char-valid-p) 'char-valid-p)
 218      (t 'identity))))
 219
 220 ;; `ucs-to-char' is a function that Mule-UCS provides.
 221 (eval-and-compile
 222   (if (featurep 'xemacs)
 223       (cond ((and (fboundp 'unicode-to-char) ;; XEmacs 21.5.
 224                   (subrp (symbol-function 'unicode-to-char)))
 225              (if (featurep 'mule)
 226                  (defalias 'mm-ucs-to-char 'unicode-to-char)
 227                (defun mm-ucs-to-char (codepoint)
 228                  "Convert Unicode codepoint to character."
 229                  (or (unicode-to-char codepoint) ?#))))
 230             ((featurep 'mule)
 231              (defun mm-ucs-to-char (codepoint)
 232                "Convert Unicode codepoint to character."
 233                (if (fboundp 'ucs-to-char) ;; Mule-UCS is loaded.
 234                    (progn
 235                      (defalias 'mm-ucs-to-char
 236                        (lambda (codepoint)
 237                          "Convert Unicode codepoint to character."
 238                          (condition-case nil
 239                              (or (ucs-to-char codepoint) ?#)
 240                            (error ?#))))
 241                      (mm-ucs-to-char codepoint))
 242                  (condition-case nil
 243                      (or (int-to-char codepoint) ?#)
 244                    (error ?#)))))
 245             (t
 246              (defun mm-ucs-to-char (codepoint)
 247                "Convert Unicode codepoint to character."
 248                (condition-case nil
 249                    (or (int-to-char codepoint) ?#)
 250                  (error ?#)))))
 251     (if (let ((char (make-char 'japanese-jisx0208 36 34)))
 252           (eq char (decode-char 'ucs char)))
 253         ;; Emacs 23.
 254         (defalias 'mm-ucs-to-char 'identity)
 255       (defun mm-ucs-to-char (codepoint)
 256         "Convert Unicode codepoint to character."
 257         (or (decode-char 'ucs codepoint) ?#)))))
 258
 259 ;; Fixme:  This seems always to be used to read a MIME charset, so it
 260 ;; should be re-named and fixed (in Emacs) to offer completion only on
 261 ;; proper charset names (base coding systems which have a
 262 ;; mime-charset defined).  XEmacs doesn't believe in mime-charset;
 263 ;; test with
 264 ;;   `(or (coding-system-get 'iso-8859-1 'mime-charset)
 265 ;;        (coding-system-get 'iso-8859-1 :mime-charset))'
 266 ;; Actually, there should be an `mm-coding-system-mime-charset'.
 267 (eval-and-compile
 268   (defalias 'mm-read-coding-system
 269     (if (featurep 'emacs) 'read-coding-system
 270       (cond
 271        ((fboundp 'read-coding-system)
 272         (if (and (featurep 'xemacs)
 273                  (<= (string-to-number emacs-version) 21.1))
 274             (lambda (prompt &optional default-coding-system)
 275               (read-coding-system prompt))
 276           'read-coding-system))
 277        (t (lambda (prompt &optional default-coding-system)
 278             "Prompt the user for a coding system."
 279             (gnus-completing-read
 280              prompt (mapcar (lambda (s) (symbol-name (car s)))
 281                             mm-mime-mule-charset-alist))))))))
 282
 283 (defvar mm-coding-system-list nil)
 284 (defun mm-get-coding-system-list ()
 285   "Get the coding system list."
 286   (or mm-coding-system-list
 287       (setq mm-coding-system-list (mm-coding-system-list))))
 288
 289 (defun mm-coding-system-p (cs)
 290   "Return non-nil if CS is a symbol naming a coding system.
 291 In XEmacs, also return non-nil if CS is a coding system object.
 292 If CS is available, return CS itself in Emacs, and return a coding
 293 system object in XEmacs."
 294   (if (fboundp 'find-coding-system)
 295       (and cs (find-coding-system cs))
 296     (if (fboundp 'coding-system-p)
 297         (when (coding-system-p cs)
 298           cs)
 299       ;; no-MULE XEmacs:
 300       (car (memq cs (mm-get-coding-system-list))))))
 301
 302 (defvar mm-charset-synonym-alist
 303   `(
 304     ;; Not in XEmacs, but it's not a proper MIME charset anyhow.
 305     ,@(unless (mm-coding-system-p 'x-ctext)
 306         '((x-ctext . ctext)))
 307     ;; ISO-8859-15 is very similar to ISO-8859-1.  But it's _different_ in 8
 308     ;; positions!
 309     ,@(unless (mm-coding-system-p 'iso-8859-15)
 310         '((iso-8859-15 . iso-8859-1)))
 311     ;; BIG-5HKSCS is similar to, but different than, BIG-5.
 312     ,@(unless (mm-coding-system-p 'big5-hkscs)
 313         '((big5-hkscs . big5)))
 314     ;; A Microsoft misunderstanding.
 315     ,@(when (and (not (mm-coding-system-p 'unicode))
 316                  (mm-coding-system-p 'utf-16-le))
 317         '((unicode . utf-16-le)))
 318     ;; A Microsoft misunderstanding.
 319     ,@(unless (mm-coding-system-p 'ks_c_5601-1987)
 320         (if (mm-coding-system-p 'cp949)
 321             '((ks_c_5601-1987 . cp949))
 322           '((ks_c_5601-1987 . euc-kr))))
 323     ;; Windows-31J is Windows Codepage 932.
 324     ,@(when (and (not (mm-coding-system-p 'windows-31j))
 325                  (mm-coding-system-p 'cp932))
 326         '((windows-31j . cp932)))
 327     ;; Charset name: GBK, Charset aliases: CP936, MS936, windows-936
 328     ;; http://www.iana.org/assignments/charset-reg/GBK
 329     ;; Emacs 22.1 has cp936, but not gbk, so we alias it:
 330     ,@(when (and (not (mm-coding-system-p 'gbk))
 331                  (mm-coding-system-p 'cp936))
 332         '((gbk . cp936)))
 333     ;; UTF8 is a bogus name for UTF-8
 334     ,@(when (and (not (mm-coding-system-p 'utf8))
 335                  (mm-coding-system-p 'utf-8))
 336         '((utf8 . utf-8)))
 337     ;; ISO8859-1 is a bogus name for ISO-8859-1
 338     ,@(when (and (not (mm-coding-system-p 'iso8859-1))
 339                  (mm-coding-system-p 'iso-8859-1))
 340         '((iso8859-1 . iso-8859-1)))
 341     ;; ISO_8859-1 is a bogus name for ISO-8859-1
 342     ,@(when (and (not (mm-coding-system-p 'iso_8859-1))
 343                  (mm-coding-system-p 'iso-8859-1))
 344         '((iso_8859-1 . iso-8859-1)))
 345     )
 346   "A mapping from unknown or invalid charset names to the real charset names.
 347
 348 See `mm-codepage-iso-8859-list' and `mm-codepage-ibm-list'.")
 349
 350 (defun mm-codepage-setup (number &optional alias)
 351   "Create a coding system cpNUMBER.
 352 The coding system is created using `codepage-setup'.  If ALIAS is
 353 non-nil, an alias is created and added to
 354 `mm-charset-synonym-alist'.  If ALIAS is a string, it's used as
 355 the alias.  Else windows-NUMBER is used."
 356   (interactive
 357    (let ((completion-ignore-case t)
 358          (candidates (if (fboundp 'cp-supported-codepages)
 359                          (cp-supported-codepages)
 360                        ;; Removed in Emacs 23 (unicode), so signal an error:
 361                        (error "`codepage-setup' not present in this Emacs version"))))
 362      (list (gnus-completing-read "Setup DOS Codepage" candidates
 363                                  t nil nil "437"))))
 364   (when alias
 365     (setq alias (if (stringp alias)
 366                     (intern alias)
 367                   (intern (format "windows-%s" number)))))
 368   (let* ((cp (intern (format "cp%s" number))))
 369     (unless (mm-coding-system-p cp)
 370       (if (fboundp 'codepage-setup)     ; silence compiler
 371           (codepage-setup number)
 372         (error "`codepage-setup' not present in this Emacs version")))
 373     (when (and alias
 374                ;; Don't add alias if setup of cp failed.
 375                (mm-coding-system-p cp))
 376       (add-to-list 'mm-charset-synonym-alist (cons alias cp)))))
 377
 378 (defcustom mm-codepage-iso-8859-list
 379   (list 1250 ;; Windows-1250 is a variant of Latin-2 heavily used by Microsoft
 380         ;; Outlook users in Czech republic.  Use this to allow reading of
 381         ;; their e-mails.
 382         '(1252 . 1) ;; Windows-1252 is a superset of iso-8859-1 (West
 383                     ;; Europe).  See also `gnus-article-dumbquotes-map&