lisp/international/mule-diag.el

   1 ;;; mule-diag.el --- show diagnosis of multilingual environment (Mule)
   2
   3 ;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003
   4 ;;   Free Software Foundation, Inc.
   5 ;; Copyright (C) 1995, 1997, 1999, 2000, 2001, 2002, 2003
   6 ;;   National Institute of Advanced Industrial Science and Technology (AIST)
   7 ;;   Registration Number H14PRO021
   8 ;; Copyright (C) 2003
   9 ;;   National Institute of Advanced Industrial Science and Technology (AIST)
  10 ;;   Registration Number H13PRO009
  11
  12 ;; Keywords: multilingual, charset, coding system, fontset, diagnosis, i18n
  13
  14 ;; This file is part of GNU Emacs.
  15
  16 ;; GNU Emacs is free software; you can redistribute it and/or modify
  17 ;; it under the terms of the GNU General Public License as published by
  18 ;; the Free Software Foundation; either version 2, or (at your option)
  19 ;; any later version.
  20
  21 ;; GNU Emacs is distributed in the hope that it will be useful,
  22 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 ;; GNU General Public License for more details.
  25
  26 ;; You should have received a copy of the GNU General Public License
  27 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  28 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  29 ;; Boston, MA 02110-1301, USA.
  30
  31 ;;; Commentary:
  32
  33 ;;; Code:
  34
  35 ;; Make sure the help-xref button type is defined.
  36 (require 'help-fns)
  37
  38 ;;; General utility function
  39
  40 (defun print-list (&rest args)
  41   "Print all arguments with single space separator in one line."
  42   (while (cdr args)
  43     (when (car args)
  44       (princ (car args))
  45       (princ " "))
  46     (setq args (cdr args)))
  47   (princ (car args))
  48   (princ "\n"))
  49
  50 ;;; CHARSET
  51
  52 (define-button-type 'sort-listed-character-sets
  53   'help-echo (purecopy "mouse-2, RET: sort on this column")
  54   'face 'bold
  55   'action #'(lambda (button)
  56               (sort-listed-character-sets (button-get button 'sort-key))))
  57
  58 (define-button-type 'list-charset-chars
  59   :supertype 'help-xref
  60   'help-function #'list-charset-chars
  61   'help-echo "mouse-2, RET: show table of characters for this character set")
  62
  63 ;;;###autoload
  64 (defun list-character-sets (arg)
  65   "Display a list of all character sets.
  66
  67 The D column contains the dimension of this character set.  The CH
  68 column contains the number of characters in a block of this character
  69 set.  The FINAL-CHAR column contains an ISO-2022 <final-char> to use
  70 for designating this character set in ISO-2022-based coding systems.
  71
  72 With prefix arg, the output format gets more cryptic,
  73 but still shows the full information."
  74   (interactive "P")
  75   (help-setup-xref (list #'list-character-sets arg) (interactive-p))
  76   (with-output-to-temp-buffer "*Character Set List*"
  77     (with-current-buffer standard-output
  78       (if arg
  79           (list-character-sets-2)
  80         ;; Insert header.
  81         (insert "Supplementary character sets are shown below.\n")
  82         (insert
  83          (substitute-command-keys
  84           (concat "Use "
  85                   (if (display-mouse-p) "\\[help-follow-mouse] or ")
  86                   "\\[help-follow]:\n")))
  87         (insert "  on a column title to sort by that title,")
  88         (indent-to 48)
  89         (insert "+----DIMENSION\n")
  90         (insert "  on a charset name to list characters.")
  91         (indent-to 48)
  92         (insert "| +--CHARS\n")
  93         (let ((columns '(("CHARSET-NAME" . name) "\t\t\t\t\t"
  94                          ("D CH  FINAL-CHAR" . iso-spec)))
  95               pos)
  96           (while columns
  97             (if (stringp (car columns))
  98                 (insert (car columns))
  99               (insert-text-button (car (car columns))
 100                                   :type 'sort-listed-character-sets
 101                                   'sort-key (cdr (car columns)))
 102               (goto-char (point-max)))
 103             (setq columns (cdr columns)))
 104           (insert "\n"))
 105         (insert "------------\t\t\t\t\t- --- ----------\n")
 106
 107         ;; Insert body sorted by charset IDs.
 108         (list-character-sets-1 'name)))))
 109
 110 (defun sort-listed-character-sets (sort-key)
 111   (if sort-key
 112       (save-excursion
 113         (let ((buffer-read-only nil))
 114           (goto-char (point-min))
 115           (search-forward "\n-")
 116           (forward-line 1)
 117           (delete-region (point) (point-max))
 118           (list-character-sets-1 sort-key)))))
 119
 120 (defun list-character-sets-1 (sort-key)
 121   "Insert a list of character sets sorted by SORT-KEY.
 122 SORT-KEY should be `name' or `iso-spec' (default `name')."
 123   (or sort-key
 124       (setq sort-key 'name))
 125   (let ((tail charset-list)
 126         charset-info-list supplementary-list charset sort-func)
 127     (dolist (charset charset-list)
 128       ;; Generate a list that contains all information to display.
 129       (let ((elt (list charset
 130                        (charset-dimension charset)
 131                        (charset-chars charset)
 132                        (charset-iso-final-char charset))))
 133         (if (plist-get (charset-plist charset) :supplementary-p)
 134             (push elt supplementary-list)
 135           (push elt charset-info-list))))
 136
 137     ;; Determine a predicate for `sort' by SORT-KEY.
 138     (setq sort-func
 139           (cond ((eq sort-key 'name)
 140                  (lambda (x y) (string< (car x) (car y))))
 141
 142                 ((eq sort-key 'iso-spec)
 143                  ;; Sort by DIMENSION CHARS FINAL-CHAR
 144                  (function
 145                   (lambda (x y)
 146                     (or (< (nth 1 x) (nth 1 y))
 147                         (and (= (nth 1 x) (nth 1 y))
 148                              (or (< (nth 2 x) (nth 2 y))
 149                                  (and (= (nth 2 x) (nth 2 y))
 150                                       (< (nth 3 x) (nth 3 y)))))))))
 151                 (t
 152                  (error "Invalid charset sort key: %s" sort-key))))
 153
 154     (setq charset-info-list (sort charset-info-list sort-func))
 155     (setq supplementary-list (sort supplementary-list sort-func))
 156
 157     ;; Insert information of character sets.
 158     (dolist (elt (append charset-info-list (list t) supplementary-list))
 159       (if (eq elt t)
 160           (insert "-------------- Supplementary Character Sets --------------")
 161         (insert-text-button (symbol-name (car elt)) ; NAME
 162                             :type 'list-charset-chars
 163                             'help-args (list (car elt)))
 164         (goto-char (point-max))
 165         (insert "\t")
 166         (indent-to 48)
 167         (insert (format "%d %3d "
 168                         (nth 1 elt) (nth 2 elt)) ; DIMENSION and CHARS
 169                 (if (< (nth 3 elt) 0)
 170                     "none"
 171                   (nth 3 elt))))        ; FINAL-CHAR
 172       (insert "\n"))))
 173
 174
 175 ;; List all character sets in a form that a program can easily parse.
 176
 177 (defun list-character-sets-2 ()
 178   (insert "#########################
 179 ## LIST OF CHARSETS
 180 ## Each line corresponds to one charset.
 181 ## The following attributes are listed in this order
 182 ## separated by a colon `:' in one line.
 183 ##      CHARSET-SYMBOL-NAME,
 184 ##      DIMENSION (1 or 2)
 185 ##      CHARS (94 or 96)
 186 ##      WIDTH (occupied column numbers: 1 or 2),
 187 ##      DIRECTION (0:left-to-right, 1:right-to-left),
 188 ##      ISO-FINAL-CHAR (character code of ISO-2022's final character)
 189 ##      ISO-GRAPHIC-PLANE (ISO-2022's graphic plane, 0:GL, 1:GR)
 190 ##      DESCRIPTION (describing string of the charset)
 191 ")
 192   (let ((l charset-list)
 193         charset)
 194     (while l
 195       (setq charset (car l) l (cdr l))
 196       (princ (format "%s:%d:%d:%d:%d:%s\n"
 197                      charset
 198                      (charset-dimension charset)
 199                      (charset-chars charset)
 200                      (aref char-width-table (make-char charset))
 201 ;;;                  (charset-direction charset)
 202                      (charset-iso-final-char charset)
 203 ;;;                  (charset-iso-graphic-plane charset)
 204                      (charset-description charset))))))
 205
 206 (defvar non-iso-charset-alist nil
 207   "Obsolete.")
 208 (make-obsolete-variable 'non-iso-charset-alist "no longer relevant" "23.1")
 209
 210 (defun decode-codepage-char (codepage code)
 211   "Decode a character that has code CODE in CODEPAGE.
 212 Return a decoded character string.  Each CODEPAGE corresponds to a
 213 coding system cpCODEPAGE.  This function is obsolete."
 214   (decode-char (intern (format "cp%d" codepage)) code))
 215 (make-obsolete 'decode-codepage-char 'decode-char "23.1")
 216
 217 ;; A variable to hold charset input history.
 218 (defvar charset-history nil)
 219
 220
 221 ;;;###autoload
 222 (defun read-charset (prompt &optional default-value initial-input)
 223   "Read a character set from the minibuffer, prompting with string PROMPT.
 224 It must be an Emacs character set listed in the variable `charset-list'.
 225
 226 Optional arguments are DEFAULT-VALUE and INITIAL-INPUT.
 227 DEFAULT-VALUE, if non-nil, is the default value.
 228 INITIAL-INPUT, if non-nil, is a string inserted in the minibuffer initially.
 229 See the documentation of the function `completing-read' for the
 230 detailed meanings of these arguments."
 231   (let* ((table (mapcar (lambda (x) (list (symbol-name x))) charset-list))
 232          (charset (completing-read prompt table
 233                                    nil t initial-input 'charset-history
 234                                    default-value)))
 235     (if (> (length charset) 0)
 236         (intern charset))))
 237
 238 ;; List characters of the range MIN and MAX of CHARSET.  If dimension
 239 ;; of CHARSET is two (i.e. 2-byte charset), ROW is the first byte
 240 ;; (block index) of the characters, and MIN and MAX are the second
 241 ;; bytes of the characters.  If the dimension is one, ROW should be 0.
 242
 243 (defun list-block-of-chars (charset row min max)
 244   (let (i ch)
 245     (insert-char ?- (+ 7 (* 4 16)))
 246     (insert "\n     ")
 247     (setq i 0)
 248     (while (< i 16)
 249       (insert (format "%4X" i))
 250       (setq i (1+ i)))
 251     (setq i (* (/ min 16) 16))
 252     (while (<= i max)
 253       (if (= (% i 16) 0)
 254           (insert (format "\n%6Xx" (/ (+ (* row 256) i) 16))))
 255       (setq ch (if (< i min)
 256                    32
 257                  (or (decode-char charset (+ (* row 256) i))
 258                      32)))              ; gap in mapping
 259       ;; Don't insert a control code.
 260       (if (or (< ch 32) (= ch 127))
 261           (setq ch (single-key-description ch))
 262         (if (and (>= ch 128) (< ch 160))
 263             (setq ch (format "%02Xh" ch))))
 264       (insert "\t" ch)
 265       (setq i (1+ i))))
 266   (insert "\n"))
 267
 268 ;;;###autoload
 269 (defun list-charset-chars (charset)
 270   "Display a list of characters in character set CHARSET."
 271   (interactive (list (read-charset "Character set: ")))
 272   (or (charsetp charset)
 273       (error "Invalid character set: %s" charset))
 274   (with-output-to-temp-buffer "*Character List*"
 275     (with-current-buffer standard-output
 276       (if (coding-system-p charset)
 277           ;; Useful to be able to do C-u C-x = to find file code, for
 278           ;; instance:
 279           (set-buffer-file-coding-system charset))
 280       (setq mode-line-format (copy-sequence mode-line-format))
 281       (let ((slot (memq 'mode-line-buffer-identification mode-line-format)))
 282         (if slot
 283             (setcdr slot
 284                     (cons (format " (%s)" charset)
 285                           (cdr slot)))))
 286       (setq tab-width 4)
 287       (set-buffer-multibyte t)
 288       (let ((dim (charset-dimension charset))
 289             (chars (charset-chars charset))
 290             ;;  (plane (charset-iso-graphic-plane charset))
 291             (plane 1)
 292             (range (plist-get (charset-plist charset) :code-space))
 293             min max min2 max2)
 294         (if (> dim 2)
 295             (error "Can only list 1- and 2-dimensional charsets"))
 296         (insert (format "Characters in the coded character set %s.\n" charset))
 297         (narrow-to-region (point) (point))
 298         (setq min (aref range 0)
 299               max (aref range 1))
 300         (if (= dim 1)
 301             (list-block-of-chars charset 0 min max)
 302           (setq min2 (aref range 2)
 303                 max2 (aref range 3))
 304           (let ((i min2))
 305             (while (<= i max2)
 306               (list-block-of-chars charset i min max)
 307               (setq i (1+ i)))))
 308         (put-text-property (point-min) (point-max) 'charset charset)
 309         (widen)))))
 310
 311
 312 ;;;###autoload
 313 (defun describe-character-set (charset)
 314   "Display information about built-in character set CHARSET."
 315   (interactive (list (read-charset "Charset: ")))
 316   (or (charsetp charset)
 317       (error "Invalid charset: %S" charset))
 318   (help-setup-xref (list #'describe-character-set charset) (interactive-p))
 319   (with-output-to-temp-buffer (help-buffer)
 320     (with-current-buffer standard-output
 321       (insert "Character set: " (symbol-name charset))
 322       (let ((name (get-charset-property charset :name)))
 323         (if (not (eq name charset))
 324             (insert " (alias of " (symbol-name name) ?\))))
 325       (insert "\n\n" (charset-description charset) "\n\n")
 326       (insert "Number of contained characters: ")
 327       (dotimes (i (charset-dimension charset))
 328         (unless (= i 0)
 329           (insert ?x))
 330         (insert (format "%d" (charset-chars charset (1+ i)))))
 331       (insert ?\n)
 332       (let ((char (charset-iso-final-char charset)))
 333         (when (> char 0)
 334           (insert "Final char of ISO2022 designation sequence: ")
 335           (insert (format "`%c'\n" char))))
 336       (insert (format "Width (how many columns on screen): %d\n"
 337                       (aref char-width-table (make-char charset))))
 338       (let (aliases)
 339         (dolist (c charset-list)
 340           (if (and (not (eq c charset))
 341                    (eq charset (get-charset-property c :name)))
 342               (push c aliases)))
 343         (if aliases
 344             (insert "Aliases: " (mapconcat #'symbol-name aliases ", ") ?\n)))
 345
 346       (dolist (elt `((:ascii-compatible-p "ASCII compatible." nil)
 347                      (:map "Map file: " identity)
 348                      (:unify-map "Unification map file: " identity)
 349                      (:invalid-code
 350                       nil
 351                       ,(lambda (c)
 352                          (format "Invalid character: %c (code %d)" c c)))
 353                      (:emacs-mule-id "Id in emacs-mule coding system: "
 354                                      number-to-string)
 355                      (:parents "Parents: "
 356                                (lambda (parents)
 357                                  (mapconcat ,(lambda (elt)
 358                                                (format "%s" elt))
 359                                             parents
 360                                             ", ")))
 361                      (:code-space "Code space: " ,(lambda (c)
 362                                                     (format "%s" c)))
 363                      (:code-offset "Code offset: " number-to-string)
 364                      (:iso-revision-number "ISO revision number: "
 365                                            number-to-string)
 366                      (:supplementary-p
 367                       "Used only as a parent of some other charset." nil)))
 368         (let ((val (get-charset-property charset (car elt))))
 369           (when val
 370             (if (cadr elt) (insert (cadr elt)))
 371             (if (nth 2 elt)
 372                 (insert (funcall (nth 2 elt) val)))
 373             (insert ?\n)))))))
 374 \f
 375 ;;; CODING-SYSTEM
 376
 377 (eval-when-compile                      ; dynamic bondage
 378   (defvar graphic-register))
 379
 380 ;; Print information about designation of each graphic register in
 381 ;; DESIGNATIONS in human readable format.  See the documentation of
 382 ;; `define-coding-system' for the meaning of DESIGNATIONS
 383 ;; (`:designation' property).
 384 (defun print-designation (designations)
 385   (let (charset)
 386     (dotimes (graphic-register 4)
 387       (setq charset (aref designations graphic-register))
 388       (princ (format
 389               "  G%d -- %s\n"
 390               graphic-register
 391               (cond ((null charset)
 392                      "never used")
 393                     ((eq charset t)
 394                      "no initial designation, and used by any charsets")
 395                     ((symbolp charset)
 396                      (format "%s:%s"
 397                              charset (charset-description charset)))
 398                     ((listp charset)
 399                      (if (charsetp (car charset))
 400                          (format "%s:%s, and also used by the following:"
 401                                  (car charset)
 402                                  (charset-description (car charset)))
 403                        "no initial designation, and used by the following:"))
 404                     (t
 405                      "invalid designation information"))))
 406       (when (listp charset)
 407         (setq charset (cdr charset))
 408         (while charset
 409           (cond ((eq (car charset) t)
 410                  (princ "\tany other charsets\n"))
 411                 ((charsetp (car charset))
 412                  (princ (format "\t%s:%s\n"
 413                                 (car charset)
 414                                 (charset-description (car charset)))))
 415                 (t
 416                  "invalid designation information"))
 417           (setq charset (cdr charset)))))))
 418
 419 ;;;###autoload
 420 (defun describe-coding-system (coding-system)
 421   "Display information about CODING-SYSTEM."
 422   (interactive "zDescribe coding system (default current choices): ")
 423   (if (null coding-system)
 424       (describe-current-coding-system)
 425     (help-setup-xref (list #'describe-coding-system coding-system)
 426                      (interactive-p))
 427     (with-output-to-temp-buffer (help-buffer)
 428       (print-coding-system-briefly coding-system 'doc-string)
 429       (let ((type (coding-system-type coding-system))
 430             ;; Fixme: use this
 431             (extra-spec (coding-system-plist coding-system)))
 432         (princ "Type: ")
 433         (princ type)
 434         (cond ((eq type 'undecided)
 435                (princ " (do automatic conversion)"))
 436               ((eq type 'utf-8)
 437                (princ " (UTF-8: Emacs internal multibyte form)"))
 438               ((eq type 'utf-16)
 439                ;; (princ " (UTF-16)")
 440                )
 441               ((eq type 'shift-jis)
 442                (princ " (Shift-JIS, MS-KANJI)"))
 443               ((eq type 'iso-2022)
 444                (princ " (variant of ISO-2022)\n")
 445                (princ "Initial designations:\n")
 446                (print-designation (coding-system-get coding-system
 447                                                      :designation))
 448
 449                (when (coding-system-get coding-system :flags)
 450                  (princ "Other specifications: \n  ")
 451                  (apply #'print-list
 452                         (coding-system-get coding-system :flags))))
 453               ((eq type 'charset)
 454                (princ " (charset)"))
 455               ((eq type 'ccl)
 456                (princ " (do conversion by CCL program)"))
 457               ((eq type 'raw-text)
 458                (princ " (text with random binary characters)"))
 459               ((eq type 'emacs-mule)
 460                (princ " (Emacs 21 internal encoding)"))
 461               (t (princ ": invalid coding-system.")))
 462         (princ "\nEOL type: ")
 463         (let ((eol-type (coding-system-eol-type coding-system)))
 464           (cond ((vectorp eol-type)
 465                  (princ "Automatic selection from:\n\t")
 466                  (princ eol-type)
 467                  (princ "\n"))
 468                 ((or (null eol-type) (eq eol-type 0)) (princ "LF\n"))
 469                 ((eq eol-type 1) (princ "CRLF\n"))
 470                 ((eq eol-type 2) (princ "CR\n"))
 471                 (t (princ "invalid\n")))))
 472       (let ((postread (coding-system-get coding-system :post-read-conversion)))
 473         (when postread
 474           (princ "After decoding text normally,")
 475           (princ " perform post-conversion using the function: ")
 476           (princ "\n  ")
 477           (princ postread)
 478           (princ "\n")))
 479       (let ((prewrite (coding-system-get coding-system :pre-write-conversion)))
 480         (when prewrite
 481           (princ "Before encoding text normally,")
 482           (princ " perform pre-conversion using the function: ")
 483           (princ "\n  ")
 484           (princ prewrite)
 485           (princ "\n")))
 486       (with-current-buffer standard-output
 487         (let ((charsets (coding-system-charset-list coding-system)))
 488           (when (and (not (eq (coding-system-base coding-system) 'raw-text))
 489                      charsets)
 490             (cond
 491              ((eq charsets 'iso-2022)
 492               (insert "This coding system can encode all ISO 2022 charsets."))
 493              ((eq charsets 'emacs-mule)
 494               (insert "This coding system can encode all emacs-mule charsets\
 495 ."""))
 496              (t
 497               (insert "This coding system encodes the following charsets:\n ")
 498               (while charsets
 499                 (insert " " (symbol-name (car charsets)))
 500                 (search-backward (symbol-name (car charsets)))
 501                 (help-xref-button 0 'help-character-set (car charsets))
 502                 (goto-char (point-max))
 503                 (setq charsets (cdr charsets)))))))))))
 504
 505 ;;;###autoload
 506 (defun describe-current-coding-system-briefly ()
 507   "Display coding systems currently used in a brief format in echo area.
 508
 509 The format is \"F[..],K[..],T[..],P>[..],P<[..], default F[..],P<[..],P<[..]\",
 510 where mnemonics of the following coding systems come in this order
 511 in place of `..':
 512   `buffer-file-coding-system' (of the current buffer)
 513   eol-type of `buffer-file-coding-system' (of the current buffer)
 514   Value returned by `keyboard-coding-system'
 515   eol-type of `keyboard-coding-system'
 516   Value returned by `terminal-coding-system'.
 517   eol-type of `terminal-coding-system'
 518   `process-coding-system' for read (of the current buffer, if any)
 519   eol-type of `process-coding-system' for read (of the current buffer, if any)
 520   `process-coding-system' for write (of the current buffer, if any)
 521   eol-type of `process-coding-system' for write (of the current buffer, if any)
 522   `default-buffer-file-coding-system'
 523   eol-type of `default-buffer-file-coding-system'
 524   `default-process-coding-system' for read
 525   eol-type of `default-process-coding-system' for read
 526   `default-process-coding-system' for write
 527   eol-type of `default-process-coding-system'"
 528   (interactive)
 529   (let* ((proc (get-buffer-process (current-buffer)))
 530          (process-coding-systems (if proc (process-coding-system proc))))
 531     (message
 532      "F[%c%s],K[%c%s],T[%c%s],P>[%c%s],P<[%c%s], default F[%c%s],P>[%c%s],P<[%c%s]"
 533      (coding-system-mnemonic buffer-file-coding-system)
 534      (coding-system-eol-type-mnemonic buffer-file-coding-system)
 535      (coding-system-mnemonic (keyboard-coding-system))
 536      (coding-system-eol-type-mnemonic (keyboard-coding-system))
 537      (coding-system-mnemonic (terminal-coding-system))
 538      (coding-system-eol-type-mnemonic (terminal-coding-system))
 539      (coding-system-mnemonic (car process-coding-systems))
 540      (coding-system-eol-type-mnemonic (car process-coding-systems))
 541      (coding-system-mnemonic (cdr process-coding-systems))
 542      (coding-system-eol-type-mnemonic (cdr process-coding-systems))
 543      (coding-system-mnemonic default-buffer-file-coding-system)
 544      (coding-system-eol-type-mnemonic default-buffer-file-coding-system)
 545      (coding-system-mnemonic (car default-process-coding-system))
 546      (coding-system-eol-type-mnemonic (car default-process-coding-system))
 547      (coding-system-mnemonic (cdr default-process-coding-system))
 548      (coding-system-eol-type-mnemonic (cdr default-process-coding-system))
 549      )))
 550
 551 (defun print-coding-system-briefly (coding-system &optional doc-string)
 552   "Print symbol name and mnemonic letter of CODING-SYSTEM with `princ'.
 553 If DOC-STRING is non-nil, print also the docstring of CODING-SYSTEM.
 554 If DOC-STRING is `tightly', don't print an empty line before the
 555 docstring, and print only the first line of the docstring."
 556   (if (not coding-system)
 557       (princ "nil\n")
 558     (princ (format "%c -- %s"
 559                    (coding-system-mnemonic coding-system)
 560                    coding-system))
 561     (let ((aliases (coding-system-aliases coding-system)))
 562       (cond ((eq coding-system (car aliases))
 563              (if (cdr aliases)
 564                  (princ (format " %S" (cons 'alias: (cdr aliases))))))
 565             ((memq coding-system aliases)
 566              (princ (format " (alias of %s)" (car aliases))))
 567             (t
 568              (let ((eol-type (coding-system-eol-type coding-system))
 569                    (base-eol-type (coding-system-eol-type (car aliases))))
 570                (if (and (integerp eol-type)
 571                         (vectorp base-eol-type)
 572                         (not (eq coding-system (aref base-eol-type eol-type))))
 573                    (princ (format " (alias of %s)"
 574                                   (aref base-eol-type eol-type))))))))
 575     (princ "\n")
 576     (or (eq doc-string 'tightly)
 577         (princ "\n"))
 578     (if doc-string
 579         (let ((doc (or (coding-system-doc-string coding-system) "")))
 580           (when (eq doc-string 'tightly)
 581             (if (string-match "\n" doc)
 582                 (setq doc (substring doc 0 (match-beginning 0))))
 583             (setq doc (concat "  " doc)))
 584           (princ (format "%s\n" doc))))))
 585
 586 ;;;###autoload
 587 (defun describe-current-coding-system ()
 588   "Display coding systems currently used, in detail."
 589   (interactive)
 590   (with-output-to-temp-buffer "*Help*"
 591     (let* ((proc (get-buffer-process (current-buffer)))
 592            (process-coding-systems (if proc (process-coding-system proc))))
 593       (princ "Coding system for saving this buffer:\n  ")
 594       (if (local-variable-p 'buffer-file-coding-system)
 595           (print-coding-system-briefly buffer-file-coding-system)
 596         (princ "Not set locally, use the default.\n"))
 597       (princ "Default coding system (for new files):\n  ")
 598       (print-coding-system-briefly default-buffer-file-coding-system)
 599       (princ "Coding system for keyboard input:\n  ")
 600       (print-coding-system-briefly (keyboard-coding-system))
 601       (princ "Coding system for terminal output:\n  ")
 602       (print-coding-system-briefly (terminal-coding-system))
 603       (princ "Coding system for inter-client cut and paste:\n  ")
 604       (print-coding-system-briefly selection-coding-system)
 605       (when (get-buffer-process (current-buffer))
 606         (princ "Coding systems for process I/O:\n")
 607         (princ "  encoding input to the process: ")
 608         (print-coding-system-briefly (cdr process-coding-systems))
 609         (princ "  decoding output from the process: ")
 610         (print-coding-system-briefly (car process-coding-systems)))
 611       (princ "Defaults for subprocess I/O:\n")
 612       (princ "  decoding: ")
 613       (print-coding-system-briefly (car default-process-coding-system))
 614       (princ "  encoding: ")
 615       (print-coding-system-briefly (cdr default-process-coding-system)))
 616
 617     (with-current-buffer standard-output
 618
 619       (princ "
 620 Priority order for recognizing coding systems when reading files:\n")
 621       (let ((i 1))
 622         (dolist (elt (coding-system-priority-list))
 623           (princ (format "  %d. %s " i elt))
 624           (let ((aliases (coding-system-aliases elt)))
 625             (if (eq elt (car aliases))
 626                 (if (cdr aliases)
 627                     (princ (cons 'alias: (cdr aliases))))
 628               (princ (list 'alias 'of (car aliases))))
 629             (terpri)
 630             (setq i (1+ i)))))
 631
 632       (princ "\n  Other coding systems cannot be distinguished automatically
 633   from these, and therefore cannot be recognized automatically
 634   with the present coding system priorities.\n\n")
 635
 636       ;; Fixme: should this be replaced or junked?
 637       (if nil
 638       (let ((categories '(coding-category-iso-7 coding-category-iso-7-else))
 639             coding-system codings)
 640         (while categories
 641           (setq coding-system (symbol-value (car categories)))
 642           (mapcar
 643            (lambda (x)
 644              (if (and (not (eq x coding-system))
 645                        (let ((flags (coding-system-get :flags)))
 646                          (not (or (memq 'use-roman flags)
 647                                   (memq 'use-oldjis flags)))))
 648                  (setq codings (cons x codings))))
 649            (get (car categories) 'coding-systems))
 650           (if codings
 651               (let ((max-col (window-width))
 652                     pos)
 653                 (princ (format "\
 654   The following are decoded correctly but recognized as %s:\n   "
 655                                coding-system))
 656                 (while codings
 657                   (setq pos (point))
 658                   (insert (format " %s" (car codings)))
 659                   (when (> (current-column) max-col)
 660                     (goto-char pos)
 661                     (insert "\n   ")
 662                     (goto-char (point-max)))
 663                   (setq codings (cdr codings)))
 664                 (insert "\n\n")))
 665           (setq categories (cdr categories)))))
 666
 667       (princ "Particular coding systems specified for certain file names:\n")
 668       (terpri)
 669       (princ "  OPERATION\tTARGET PATTERN\t\tCODING SYSTEM(s)\n")
 670       (princ "  ---------\t--------------\t\t----------------\n")
 671       (let ((func (lambda (operation alist)
 672                     (princ "  ")
 673                     (princ operation)
 674                     (if (not alist)
 675                         (princ "\tnothing specified\n")
 676                       (while alist
 677                         (indent-to 16)
 678                         (prin1 (car (car alist)))
 679                         (if (>= (current-column) 40)
 680                             (newline))
 681                         (indent-to 40)
 682                         (princ (cdr (car alist)))
 683                         (princ "\n")
 684                         (setq alist (cdr alist)))))))
 685         (funcall func "File I/O" file-coding-system-alist)
 686         (funcall func "Process I/O" process-coding-system-alist)
 687         (funcall func "Network I/O" network-coding-system-alist))
 688       (help-mode))))
 689
 690 (defun print-coding-system (coding-system)
 691   "Print detailed information on CODING-SYSTEM."
 692   (let ((type (coding-system-type coding-system))
 693         (eol-type (coding-system-eol-type coding-system))
 694         (flags (coding-system-get coding-system :flags))
 695         (aliases (coding-system-aliases coding-system)))
 696     (if (not (eq (car aliases) coding-system))
 697         (princ (format "%s (alias of %s)\n" coding-system (car aliases)))
 698       (princ coding-system)
 699       (setq aliases (cdr aliases))
 700       (while aliases
 701         (princ ",")
 702         (princ (car aliases))
 703         (setq aliases (cdr aliases)))
 704       (princ (format ":%s:%c:%d:"
 705                      type
 706                      (coding-system-mnemonic coding-system)
 707                      (if (integerp eol-type) eol-type 3)))
 708       (cond ((eq type 'iso2022)
 709              (let ((idx 0)
 710                    charset)
 711                (while (< idx 4)
 712                  (setq charset (aref flags idx))
 713                  (cond ((null charset)
 714                         (princ -1))
 715                        ((eq charset t)
 716                         (princ -2))
 717                        ((charsetp charset)
 718                         (princ charset))
 719                        ((listp charset)
 720                         (princ "(")
 721                         (princ (car charset))
 722                         (setq charset (cdr charset))
 723                         (while charset
 724                           (princ ",")
 725                           (princ (car charset))
 726                           (setq charset (cdr charset)))
 727                         (princ ")")))
 728                  (princ ",")
 729                  (setq idx (1+ idx)))
 730                (while (< idx 12)
 731                  (princ (if (aref flags idx) 1 0))
 732                  (princ ",")
 733                  (setq idx (1+ idx)))
 734                (princ (if (aref flags idx) 1 0))))
 735             ((eq type 'ccl)
 736              (let (i len)
 737                (if (symbolp (car flags))
 738                    (princ (format " %s" (car flags)))
 739                  (setq i 0 len (length (car flags)))
 740                  (while (< i len)
 741                    (princ (format " %x" (aref (car flags) i)))
 742                    (setq i (1+ i))))
 743                (princ ",")
 744                (if (symbolp (cdr flags))
 745                    (princ (format "%s" (cdr flags)))
 746                  (setq i 0 len (length (cdr flags)))
 747                  (while (< i len)
 748                    (princ (format " %x" (aref (cdr flags) i)))
 749                    (setq i (1+ i))))))
 750             (t (princ 0)))
 751       (princ ":")
 752       (princ (coding-system-doc-string coding-system))
 753       (princ "\n"))))
 754
 755 ;;;###autoload
 756 (defun list-coding-systems (&optional arg)
 757   "Display a list of all coding systems.
 758 This shows the mnemonic letter, name, and description of each coding system.
 759
 760 With prefix arg, the output format gets more cryptic,
 761 but still contains full information about each coding system."
 762   (interactive "P")
 763   (with-output-to-temp-buffer "*Help*"
 764     (list-coding-systems-1 arg)))
 765
 766 (defun list-coding-systems-1 (arg)
 767   (if (null arg)
 768       (princ "\
 769 ###############################################
 770 # List of coding systems in the following format:
 771 # MNEMONIC-LETTER -- CODING-SYSTEM-NAME
 772 #   DOC-STRING
 773 ")
 774     (princ "\
 775 #########################
 776 ## LIST OF CODING SYSTEMS
 777 ## Each line corresponds to one coding system
 778 ## Format of a line is:
 779 ##   NAME[,ALIAS...]:TYPE:MNEMONIC:EOL:FLAGS:POST-READ-CONVERSION
 780 ##      :PRE-WRITE-CONVERSION:DOC-STRING,
 781 ## where
 782 ##  NAME = coding system name
 783 ##  ALIAS = alias of the coding system
 784 ##  TYPE = nil (no conversion), t (undecided or automatic detection),
 785 ##         0 (EMACS-MULE), 1 (SJIS), 2 (ISO2022), 3 (BIG5), or 4 (CCL)
 786 ##  EOL = 0 (LF), 1 (CRLF), 2 (CR), or 3 (Automatic detection)
 787 ##  FLAGS =
 788 ##    if TYPE = 2 then
 789 ##      comma (`,') separated data of the following:
 790 ##        G0, G1, G2, G3, SHORT-FORM, ASCII-EOL, ASCII-CNTL, SEVEN,
 791 ##        LOCKING-SHIFT, SINGLE-SHIFT, USE-ROMAN, USE-OLDJIS, NO-ISO6429
 792 ##    else if TYPE = 4 then
 793 ##      comma (`,') separated CCL programs for read and write
 794 ##    else
 795 ##      0
 796 ##  POST-READ-CONVERSION, PRE-WRITE-CONVERSION = function name to be called
 797 ##
 798 "))
 799   (dolist (coding-system (sort-coding-systems (coding-system-list 'base-only)))
 800     (if (null arg)
 801         (print-coding-system-briefly coding-system 'tightly)
 802       (print-coding-system coding-system))))
 803
 804 ;; Fixme: delete?
 805 ;;;###autoload
 806 (defun list-coding-categories ()
 807   "Display a list of all coding categories."
 808   (with-output-to-temp-buffer "*Help*"
 809     (princ "\
 810 ############################
 811 ## LIST OF CODING CATEGORIES (ordered by priority)
 812 ## CATEGORY:CODING-SYSTEM
 813 ##
 814 ")
 815     (let ((l coding-category-list))
 816       (while l
 817         (princ (format "%s:%s\n" (car l) (symbol-value (car l))))
 818         (setq l (cdr l))))))
 819 \f
 820 ;;; FONT
 821
 822 (defun describe-font-internal (font-info &optional verbose)
 823   "Print information about a font in FONT-INFO."
 824   (print-list "name (opened by):" (aref font-info 0))
 825   (print-list "       full name:" (aref font-info 1))
 826   (print-list "            size:" (format "%2d" (aref font-info 2)))
 827   (print-list "          height:" (format "%2d" (aref font-info 3)))
 828   (print-list " baseline-offset:" (format "%2d" (aref font-info 4)))
 829   (print-list "relative-compose:" (format "%2d" (aref font-info 5))))
 830
 831 ;;;###autoload
 832 (defun describe-font (fontname)
 833   "Display information about fonts which partially match FONTNAME."
 834   (interactive "sFontname (default current choice for ASCII chars): ")
 835   (or (and window-system (fboundp 'fontset-list))
 836       (error "No fontsets being used"))
 837   (when (or (not fontname) (= (length fontname) 0))
 838     (setq fontname (cdr (assq 'font (frame-parameters))))
 839     (if (query-fontset fontname)
 840         (setq fontname
 841               (nth 1 (assq 'ascii (aref (fontset-info fontname) 2))))))
 842   (let ((font-info (font-info fontname)))
 843     (if (null font-info)
 844         (message "No matching font")
 845       (with-output-to-temp-buffer "*Help*"
 846         (describe-font-internal font-info 'verbose)))))
 847
 848 (defun print-fontset-element (val)
 849   ;; VAL has this format:
 850   ;;  ((REQUESTED-FONT-NAME OPENED-FONT-NAME ...) ...)
 851   ;; CHAR RANGE is already inserted.  Get character codes from
 852   ;; the current line.
 853   (beginning-of-line)
 854   (let ((from (following-char))
 855         (to (if (looking-at "[^.]*[.]* ")
 856                 (char-after (match-end 0)))))
 857     (if (re-search-forward "[ \t]*$" nil t)
 858         (delete-region (match-beginning 0) (match-end 0)))
 859
 860     ;; For non-ASCII characters, insert also CODE RANGE.
 861     (if (or (>= from 128) (and to (>= to 128)))
 862         (if to
 863             (insert (format " (#x%02X .. #x%02X)" from to))
 864           (insert (format " (#x%02X)" from))))
 865
 866     ;; Insert a requested font name.
 867     (dolist (elt val)
 868       (let ((requested (car elt)))
 869         (if (stringp requested)
 870             (insert "\n    " requested)
 871           (let ((family (aref requested 0))
 872                 (registry (aref requested 5)))
 873             (if (not family)
 874                 (setq family "*-*")
 875               (or (string-match "-" family)
 876                   (setq family (concat "*-" family))))
 877             (or (string-match "-" registry)
 878                 (= (aref registry (1- (length registry))) ?*)
 879                 (setq registry (concat registry "*")))
 880             (insert "\n    -" family
 881                     ?- (or (aref requested 1) ?*) ; weight
 882                     ?- (or (aref requested 2) ?*) ; slant
 883                     ?- (or (aref requested 3) ?*) ; width
 884                     ?- (or (aref requested 4) ?*) ; adstyle
 885                     "-*-*-*-*-*-*-" registry))))
 886
 887       ;; Insert opened font names (if any).
 888       (if (and (boundp 'print-opened) (symbol-value 'print-opened))
 889           (dolist (opened (cdr elt))
 890             (insert "\n\t[" opened "]"))))))
 891
 892 (defun print-fontset (fontset &optional print-opened)
 893   "Print information about FONTSET.
 894 If FONTSET is nil, print information about the default fontset.
 895 If optional arg PRINT-OPENED is non-nil, also print names of all opened
 896 fonts for FONTSET.  This function actually inserts the information in
 897 the current buffer."
 898   (or fontset
 899       (setq fontset (query-fontset "fontset-default")))
 900   (beginning-of-line)
 901   (insert "Fontset: " fontset "\n")
 902   (insert (propertize "CHAR RANGE" 'face 'underline)
 903            " (" (propertize "CODE RANGE" 'face 'underline) ")\n")
 904   (insert "    " (propertize "FONT NAME" 'face 'underline)
 905           " (" (propertize "REQUESTED" 'face 'underline)
 906           " and [" (propertize "OPENED" 'face 'underline) "])")
 907   (let ((info (fontset-info fontset)))
 908     (describe-vector info 'print-fontset-element)
 909     (insert "\n  ---<fallback to the default fontset>---")
 910     (describe-vector (char-table-extra-slot info 0) 'print-fontset-element)))
 911
 912 ;;;###autoload
 913 (defun describe-fontset (fontset)
 914   "Display information about FONTSET.
 915 This shows which font is used for which character(s)."
 916   (interactive
 917    (if (not (and window-system (fboundp 'fontset-list)))
 918        (error "No fontsets being used")
 919      (let ((fontset-list (nconc
 920                           (fontset-list)
 921                           (mapcar 'cdr fontset-alias-alist)))
 922            (completion-ignore-case t))
 923        (list (completing-read
 924               "Fontset (default used by the current frame): "
 925               fontset-list nil t)))))
 926   (if (= (length fontset) 0)
 927       (setq fontset (frame-parameter nil 'font)))
 928   (setq fontset (query-fontset fontset))
 929   (help-setup-xref (list #'describe-fontset fontset) (interactive-p))
 930   (with-output-to-temp-buffer (help-buffer)
 931     (with-current-buffer standard-output
 932       (print-fontset fontset t))))
 933
 934 ;;;###autoload
 935 (defun list-fontsets (arg)
 936   "Display a list of all fontsets.
 937 This shows the name, size, and style of each fontset.
 938 With prefix arg, also list the fonts contained in each fontset;
 939 see the function `describe-fontset' for the format of the list."
 940   (interactive "P")
 941   (if (not (and window-system (fboundp 'fontset-list)))
 942       (error "No fontsets being used")
 943     (help-setup-xref (list #'list-fontsets arg) (interactive-p))
 944     (with-output-to-temp-buffer (help-buffer)
 945       (with-current-buffer standard-output
 946         ;; This code is duplicated near the end of mule-diag.
 947         (let ((fontsets
 948                (sort (fontset-list)
 949                      (lambda (x y)
 950                        (string< (fontset-plain-name x)
 951                                 (fontset-plain-name y))))))
 952           (while fontsets
 953             (if arg
 954                 (print-fontset (car fontsets) nil)
 955               (insert "Fontset: " (car fontsets) "\n"))
 956             (setq fontsets (cdr fontsets))))))))
 957 \f
 958 ;;;###autoload
 959 (defun list-input-methods ()
 960   "Display information about all input methods."
 961   (interactive)
 962   (help-setup-xref '(list-input-methods) (interactive-p))
 963   (with-output-to-temp-buffer (help-buffer)
 964     (list-input-methods-1)
 965     (with-current-buffer standard-output
 966       (save-excursion
 967         (goto-char (point-min))
 968         (while (re-search-forward
 969                 "^  \\([^ ]+\\) (`.*' in mode line)$" nil t)
 970           (help-xref-button 1 'help-input-method (match-string 1)))))))
 971
 972 (defun list-input-methods-1 ()
 973   (if (not input-method-alist)
 974       (progn
 975         (princ "
 976 No input method is available, perhaps because you have not
 977 installed LEIM (Libraries of Emacs Input Methods)."))
 978     (princ "LANGUAGE\n  NAME (`TITLE' in mode line)\n")
 979     (princ "    SHORT-DESCRIPTION\n------------------------------\n")
 980     (setq input-method-alist
 981           (sort input-method-alist
 982                 (lambda (x y) (string< (nth 1 x) (nth 1 y)))))
 983     (let ((l input-method-alist)
 984           language elt)
 985       (while l
 986         (setq elt (car l) l (cdr l))
 987         (when (not (equal language (nth 1 elt)))
 988           (setq language (nth 1 elt))
 989           (princ language)
 990           (terpri))
 991         (princ (format "  %s (`%s' in mode line)\n    %s\n"
 992                        (car elt)
 993                        (let ((title (nth 3 elt)))
 994                          (if (and (consp title) (stringp (car title)))
 995                              (car title)
 996                            title))
 997                        (let ((description (nth 4 elt)))
 998                          (string-match ".*" description)
 999                          (match-string 0 description))))))))
1000 \f
1001 ;;; DIAGNOSIS
1002
1003 ;; Insert a header of a section with SECTION-NUMBER and TITLE.
1004 (defun insert-section (section-number title)
1005   (insert "########################################\n"
1006           "# Section " (format "%d" section-number) ".  " title "\n"
1007           "########################################\n\n"))
1008
1009 ;;;###autoload
1010 (defun mule-diag ()
1011   "Display diagnosis of the multilingual environment (Mule).
1012
1013 This shows various information related to the current multilingual
1014 environment, including lists of input methods, coding systems,
1015 character sets, and fontsets (if Emacs is running under a window
1016 system which uses fontsets)."
1017   (interactive)
1018   (with-output-to-temp-buffer "*Mule-Diagnosis*"
1019     (with-current-buffer standard-output
1020       (insert "###############################################\n"
1021               "### Current Status of Multilingual Features ###\n"
1022               "###############################################\n\n"
1023               "CONTENTS: Section 1.  General Information\n"
1024               "          Section 2.  Display\n"
1025               "          Section 3.  Input methods\n"
1026               "          Section 4.  Coding systems\n"
1027               "          Section 5.  Character sets\n")
1028       (if (and window-system (fboundp 'fontset-list))
1029           (insert "          Section 6.  Fontsets\n"))
1030       (insert "\n")
1031
1032       (insert-section 1 "General Information")
1033       (insert "Version of this emacs:\n  " (emacs-version) "\n\n")
1034       (insert "Configuration options:\n  " system-configuration-options "\n\n")
1035       (insert "Multibyte characters awareness:\n"
1036               (format "  default: %S\n" default-enable-multibyte-characters)
1037               (format "  current-buffer: %S\n\n" enable-multibyte-characters))
1038       (insert "Current language environment: " current-language-environment
1039               "\n\n")
1040
1041       (insert-section 2 "Display")
1042       (if window-system
1043           (insert "Window-system: "
1044                   (symbol-name window-system)
1045                   (format "%s" window-system-version))
1046         (insert "Terminal: " (getenv "TERM")))
1047       (insert "\n\n")
1048
1049       (if (eq window-system 'x)
1050           (let ((font (cdr (assq 'font (frame-parameters)))))
1051             (insert "The selected frame is using the "
1052                     (if (query-fontset font) "fontset" "font")
1053                     ":\n\t" font))
1054         (insert "Coding system of the terminal: "
1055                 (symbol-name (terminal-coding-system))))
1056       (insert "\n\n")
1057
1058       (insert-section 3 "Input methods")
1059       (list-input-methods-1)
1060       (insert "\n")
1061       (if default-input-method
1062           (insert (format "Default input method: %s\n" default-input-method))
1063         (insert "No default input method is specified\n"))
1064
1065       (insert-section 4 "Coding systems")
1066       (list-coding-systems-1 t)
1067       (insert "\n")
1068
1069       (insert-section 5 "Character sets")
1070       (list-character-sets-2)
1071       (insert "\n")
1072
1073       (when (and window-system (fboundp 'fontset-list))
1074         ;; This code duplicates most of list-fontsets.
1075         (insert-section 6 "Fontsets")
1076         (insert "Fontset-Name\t\t\t\t\t\t  WDxHT Style\n")
1077         (insert "------------\t\t\t\t\t\t  ----- -----\n")
1078         (let ((fontsets (fontset-list)))
1079           (while fontsets
1080             (print-fontset (car fontsets) t)
1081             (setq fontsets (cdr fontsets)))))
1082       (print-help-return-message))))
1083
1084 ;;;###autoload
1085 (defcustom unicodedata-file nil
1086   "Location of UnicodeData file.
1087 This is the UnicodeData.txt file from the Unicode consortium, used for
1088 diagnostics.  If it is non-nil `describe-char-after' will print data
1089 looked up from it."
1090   :group 'mule
1091   :type '(choice (const :tag "None" nil)
1092                  file))
1093
1094 ;; We could convert the unidata file into a Lispy form once-for-all
1095 ;; and distribute it for loading on demand.  It might be made more
1096 ;; space-efficient by splitting strings word-wise and replacing them
1097 ;; with lists of symbols interned in a private obarray, e.g.
1098 ;; "LATIN SMALL LETTER A" => '(LATIN SMALL LETTER A).
1099
1100 ;;;###autoload
1101 (defun unicode-data (char)
1102   "Return a list of Unicode data for unicode CHAR.
1103 Each element is a list of a property description and the property value.
1104 The list is null if CHAR isn't found in `unicodedata-file'."
1105   (when unicodedata-file
1106     (unless (file-exists-p unicodedata-file)
1107       (error "`unicodedata-file' %s not found" unicodedata-file))
1108     (save-excursion
1109       (set-buffer (find-file-noselect unicodedata-file t t))
1110       (goto-char (point-min))
1111       (let ((hex (format "%04X" char))
1112             found first last)
1113         (if (re-search-forward (concat "^" hex) nil t)
1114             (setq found t)
1115           ;; It's not listed explicitly.  Look for ranges, e.g. CJK
1116           ;; ideographs, and check whether it's in one of them.
1117           (while (and (re-search-forward "^\\([^;]+\\);[^;]+First>;" nil t)
1118                       (>= char (setq first
1119                                      (string-to-number (match-string 1) 16)))
1120                       (progn
1121                         (forward-line 1)
1122                         (looking-at "^\\([^;]+\\);[^;]+Last>;")
1123                         (> char
1124                            (setq last
1125                                  (string-to-number (match-string 1) 16))))))
1126           (if (and (>= char first)
1127                    (<= char last))
1128               (setq found t)))
1129         (if found
1130             (let ((fields (mapcar (lambda (elt)
1131                                     (if (> (length elt) 0)
1132                                         elt))
1133                                   (cdr (split-string
1134                                         (buffer-substring
1135                                          (line-beginning-position)
1136                                          (line-end-position))
1137                                         ";")))))
1138               ;; The length depends on whether the last field was empty.
1139               (unless (or (= 13 (length fields))
1140                           (= 14 (length fields)))
1141                 (error "Invalid contents in %s" unicodedata-file))
1142               ;; The field names and values lists are slightly
1143               ;; modified from Mule-UCS unidata.el.
1144               (list
1145                (list "Name" (let ((name (nth 0 fields)))
1146                               ;; Check for <..., First>, <..., Last>
1147                               (if (string-match "\\`\\(<[^,]+\\)," name)
1148                                   (concat (match-string 1 name) ">")
1149                                 name)))
1150                (list "Category"
1151                      (cdr (assoc
1152                            (nth 1 fields)
1153                            '(("Lu" . "uppercase letter")
1154                              ("Ll" . "lowercase letter")
1155                              ("Lt" . "titlecase letter")
1156                              ("Mn" . "non-spacing mark")
1157                              ("Mc" . "spacing-combining mark")
1158                              ("Me" . "enclosing mark")
1159                              ("Nd" . "decimal digit")
1160                              ("Nl" . "letter number")
1161                              ("No" . "other number")
1162                              ("Zs" . "space separator")
1163                              ("Zl" . "line separator")
1164                              ("Zp" . "paragraph separator")
1165                              ("Cc" . "other control")
1166                              ("Cf" . "other format")
1167                              ("Cs" . "surrogate")
1168                              ("Co" . "private use")
1169                              ("Cn" . "not assigned")
1170                              ("Lm" . "modifier letter")
1171                              ("Lo" . "other letter")
1172                              ("Pc" . "connector punctuation")
1173                              ("Pd" . "dash punctuation")
1174                              ("Ps" . "open punctuation")
1175                              ("Pe" . "close punctuation")
1176                              ("Pi" . "initial-quotation punctuation")
1177                              ("Pf" . "final-quotation punctuation")
1178                              ("Po" . "other punctuation")
1179                              ("Sm" . "math symbol")
1180                              ("Sc" . "currency symbol")
1181                              ("Sk" . "modifier symbol")
1182                              ("So" . "other symbol")))))
1183                (list "Combining class"
1184                      (cdr (assoc
1185                            (string-to-number (nth 2 fields))
1186                            '((0 . "Spacing")
1187                              (1 . "Overlays and interior")
1188                              (7 . "Nuktas")
1189                              (8 . "Hiragana/Katakana voicing marks")
1190                              (9 . "Viramas")
1191                              (10 . "Start of fixed position classes")
1192                              (199 . "End of fixed position classes")
1193                              (200 . "Below left attached")
1194                              (202 . "Below attached")
1195                              (204 . "Below right attached")
1196                              (208 . "Left attached (reordrant around \
1197 single base character)")
1198                              (210 . "Right attached")
1199                              (212 . "Above left attached")
1200                              (214 . "Above attached")
1201                              (216 . "Above right attached")
1202                              (218 . "Below left")
1203                              (220 . "Below")
1204                              (222 . "Below right")
1205                              (224 . "Left (reordrant around single base \
1206 character)")
1207                              (226 . "Right")
1208                              (228 . "Above left")
1209                              (230 . "Above")
1210                              (232 . "Above right")
1211                              (233 . "Double below")
1212                              (234 . "Double above")
1213                              (240 . "Below (iota subscript)")))))
1214                (list "Bidi category"
1215                      (cdr (assoc
1216                            (nth 3 fields)
1217                            '(("L" . "Left-to-Right")
1218                              ("LRE" . "Left-to-Right Embedding")
1219                              ("LRO" . "Left-to-Right Override")
1220                              ("R" . "Right-to-Left")
1221                              ("AL" . "Right-to-Left Arabic")
1222                              ("RLE" . "Right-to-Left Embedding")
1223                              ("RLO" . "Right-to-Left Override")
1224                              ("PDF" . "Pop Directional Format")
1225                              ("EN" . "European Number")
1226                              ("ES" . "European Number Separator")
1227                              ("ET" . "European Number Terminator")
1228                              ("AN" . "Arabic Number")
1229                              ("CS" . "Common Number Separator")
1230                              ("NSM" . "Non-Spacing Mark")
1231                              ("BN" . "Boundary Neutral")
1232                              ("B" . "Paragraph Separator")
1233                              ("S" . "Segment Separator")
1234                              ("WS" . "Whitespace")
1235                              ("ON" . "Other Neutrals")))))
1236                (list "Decomposition"
1237                      (if (nth 4 fields)
1238                          (let* ((parts (split-string (nth 4 fields)))
1239                                 (info (car parts)))
1240                            (if (string-match "\\`<\\(.+\\)>\\'" info)
1241                                (setq info (match-string 1 info))
1242                              (setq info nil))
1243                            (if info (setq parts (cdr parts)))
1244                            (setq parts (mapconcat
1245                                         (lambda (arg)
1246                                           (string (string-to-number arg 16)))
1247                                         parts " "))
1248                            (concat info parts))))
1249                (list "Decimal digit value"
1250                      (nth 5 fields))
1251                (list "Digit value"
1252                      (nth 6 fields))
1253                (list "Numeric value"
1254                      (nth 7 fields))
1255                (list "Mirrored"
1256                      (if (equal "Y" (nth 8 fields))
1257                          "yes"))
1258                (list "Old name" (nth 9 fields))
1259                (list "ISO 10646 comment" (nth 10 fields))
1260                (list "Uppercase" (and (nth 11 fields)
1261                                       (string (string-to-number
1262                                                (nth 11 fields) 16))))
1263                (list "Lowercase" (and (nth 12 fields)
1264                                       (string (string-to-number
1265                                                (nth 12 fields) 16))))
1266                (list "Titlecase" (and (nth 13 fields)
1267                                       (string (string-to-number
1268                                                (nth 13 fields) 16)))))))))))
1269
1270 (provide 'mule-diag)
1271
1272 ;;; arch-tag: cd3b607c-2893-45a0-a4fa-a6535754dbee
1273 ;;; mule-diag.el ends here