git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/utf-2000/char-db-util.el

   1 ;;; char-db-util.el --- Character Database utility -*- coding: utf-8-er; -*-
   2
   3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
   4 ;;   2007 MORIOKA Tomohiko.
   5
   6 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   7 ;; Keywords: CHISE, Character Database, ISO/IEC 10646, UCS, Unicode, MULE.
   8
   9 ;; This file is part of XEmacs CHISE.
  10
  11 ;; XEmacs CHISE is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; XEmacs CHISE is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with XEmacs CHISE; see the file COPYING.  If not, write to
  23 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 (require 'alist)
  29
  30 (defconst unidata-normative-category-alist
  31   '(("Lu" letter        uppercase)
  32     ("Ll" letter        lowercase)
  33     ("Lt" letter        titlecase)
  34     ("Mn" mark          non-spacing)
  35     ("Mc" mark          spacing-combining)
  36     ("Me" mark          enclosing)
  37     ("Nd" number        decimal-digit)
  38     ("Nl" number        letter)
  39     ("No" number        other)
  40     ("Zs" separator     space)
  41     ("Zl" separator     line)
  42     ("Zp" separator     paragraph)
  43     ("Cc" other         control)
  44     ("Cf" other         format)
  45     ("Cs" other         surrogate)
  46     ("Co" other         private-use)
  47     ("Cn" other         not-assigned)))
  48
  49 (defconst unidata-informative-category-alist
  50   '(("Lm" letter        modifier)
  51     ("Lo" letter        other)
  52     ("Pc" punctuation   connector)
  53     ("Pd" punctuation   dash)
  54     ("Ps" punctuation   open)
  55     ("Pe" punctuation   close)
  56     ("Pi" punctuation   initial-quote)
  57     ("Pf" punctuation   final-quote)
  58     ("Po" punctuation   other)
  59     ("Sm" symbol        math)
  60     ("Sc" symbol        currency)
  61     ("Sk" symbol        modifier)
  62     ("So" symbol        other)
  63     ))
  64
  65 (defconst ideographic-radicals
  66   (let ((v (make-vector 215 nil))
  67         (i 1))
  68     (while (< i 215)
  69       (aset v i (decode-char '=ucs (+ #x2EFF i)))
  70       (setq i (1+ i)))
  71     v))
  72
  73 (defun ideographic-radical (number)
  74   (aref ideographic-radicals number))
  75
  76 (defconst shuowen-radicals
  77   [?一 ?上 ?示 ?三 ?王 ?玉 ?玨 ?气 ?士 ?丨
  78    ?屮 ?艸 ?蓐 ?茻 ?小 ?八 ?釆 ?半 ?牛 ?犛
  79    ?告 ?口 ?凵 ?吅 ?哭 ?走 ?止 ?癶 ?步 ?此
  80    ?正 ?是 ?辵 ?彳 ?廴 ?𢓊 ?行 ?齒 ?牙 ?足
  81    ?疋 ?品 ?龠 ?冊 ?㗊 ?舌 ?干 ?谷 ?只 ?㕯
  82    ?句 ?丩 ?古 ?十 ?卅 ?言 ?誩 ?音 ?䇂 ?丵
  83    ?菐 ?𠬞 ?廾 ?共 ?異 ?舁 ?𦥑 ?䢅 ?爨 ?革
  84    ?鬲 ?䰜 ?爪 ?𠃨 ?鬥 ?又 ?𠂇 ?㕜 ?支 ?𦘒
  85    ?聿 ?畫 ?隶 ?堅 ?臣 ?殳 ?殺 ?𠘧 ?寸 ?皮
  86    ?㼱 ?攴 ?敎 ?卜 ?用 ?爻 ?㸚 ?𥄎 ?目 ?䀠
  87    ?眉 ?盾 ?自 ?白 ?鼻 ?皕 ?習 ?羽 ?隹 ?奞
  88    ?萑 ?𦫳 ?苜 ?羊 ?羴 ?瞿 ?雔 ?雥 ?鳥])
  89
  90 (defun shuowen-radical (number)
  91   (aref shuowen-radicals (1- number)))
  92
  93 (defvar char-db-file-coding-system 'utf-8-mcs-er)
  94
  95 (defvar char-db-feature-domains
  96   '(ucs ucs/compat daikanwa cns gt jis jis/alt jis/a jis/b
  97         jis-x0212 jis-x0213 cdp shinjigen misc unknown))
  98
  99 (defvar char-db-ignored-attributes '(ideographic-products))
 100
 101 (defun char-attribute-name< (ka kb)
 102   (cond
 103    ((eq '->denotational kb)
 104     t)
 105    ((eq '->subsumptive kb)
 106     (not (eq '->denotational ka)))
 107    ((eq '->denotational ka)
 108     nil)
 109    ((eq '->subsumptive ka)
 110     nil)
 111    ((and (symbolp ka)
 112          (string-match "^->" (symbol-name ka)))
 113     (cond ((and (symbolp kb)
 114                 (string-match "^->" (symbol-name kb)))
 115            (string< (symbol-name ka)
 116                     (symbol-name kb))
 117            ))
 118     )
 119    ((and (symbolp kb)
 120          (string-match "^->" (symbol-name kb)))
 121     t)
 122    ((and (symbolp ka)
 123          (string-match "^<-" (symbol-name ka)))
 124     (cond ((symbolp kb)
 125            (cond ((string-match "^<-" (symbol-name kb))
 126                   (string< (symbol-name ka)
 127                            (symbol-name kb))
 128                   )
 129                  ;; ((string-match "^->" (symbol-name kb))
 130                  ;;  t)
 131                  )))
 132     )
 133    ((and (symbolp kb)
 134          (string-match "^<-" (symbol-name kb)))
 135     t
 136     ;; (not (string-match "^->" (symbol-name ka)))
 137     )
 138    ((find-charset ka)
 139     (if (find-charset kb)
 140         (if (<= (charset-id ka) 1)
 141             (if (<= (charset-id kb) 1)
 142                 (cond
 143                  ((= (charset-dimension ka)
 144                      (charset-dimension kb))
 145                   (> (charset-id ka)(charset-id kb)))
 146                  (t
 147                   (> (charset-dimension ka)
 148                      (charset-dimension kb))
 149                   ))
 150               t)
 151           (if (<= (charset-id kb) 1)
 152               nil
 153             (< (charset-id ka)(charset-id kb))))
 154       nil))
 155    ((find-charset kb)
 156     t)
 157    ((symbolp ka)
 158     (cond ((symbolp kb)
 159            (string< (symbol-name ka)
 160                     (symbol-name kb)))
 161           (t)))
 162    ((symbolp kb)
 163     nil)))
 164
 165 (defvar char-db-coded-charset-priority-list
 166   '(ascii
 167     control-1
 168     latin-iso8859-1
 169     latin-iso8859-2
 170     latin-iso8859-3
 171     latin-iso8859-4
 172     latin-iso8859-9
 173     latin-jisx0201
 174     cyrillic-iso8859-5
 175     greek-iso8859-7
 176     thai-tis620
 177     =jis-x0208
 178     =jis-x0208@1978
 179     =jis-x0208@1983
 180     japanese-jisx0212
 181     chinese-gb2312
 182     =jis-x0208@1990
 183     chinese-cns11643-1
 184     chinese-cns11643-2
 185     chinese-cns11643-3
 186     chinese-cns11643-4
 187     chinese-cns11643-5
 188     chinese-cns11643-6
 189     chinese-cns11643-7
 190     =jis-x0213-1-2000
 191     =jis-x0213-2-2000
 192     korean-ksc5601
 193     chinese-isoir165
 194     katakana-jisx0201
 195     hebrew-iso8859-8
 196     chinese-gb12345
 197     latin-viscii
 198     ethiopic-ucs
 199     =big5-cdp
 200     =gt
 201     ideograph-daikanwa-2
 202     ideograph-daikanwa
 203     =cbeta
 204     ideograph-hanziku-1
 205     ideograph-hanziku-2
 206     ideograph-hanziku-3
 207     ideograph-hanziku-4
 208     ideograph-hanziku-5
 209     ideograph-hanziku-6
 210     ideograph-hanziku-7
 211     ideograph-hanziku-8
 212     ideograph-hanziku-9
 213     ideograph-hanziku-10
 214     ideograph-hanziku-11
 215     ideograph-hanziku-12
 216     =gt-k
 217     =ucs@iso
 218     =ucs@unicode
 219     =big5
 220     =big5-eten
 221     =jis-x0208@1997
 222     =zinbun-oracle
 223     =ruimoku-v6
 224     =jef-china3))
 225
 226 (defun char-db-make-char-spec (char)
 227   (let (ret char-spec)
 228     (cond ((characterp char)
 229            (cond ((and (setq ret (encode-char char '=ucs 'defined-only))
 230                        (not (and (<= #xE000 ret)(<= ret #xF8FF))))
 231                   (setq char-spec (list (cons '=ucs ret)))
 232                   (cond ((setq ret (get-char-attribute char 'name))
 233                          (setq char-spec (cons (cons 'name ret) char-spec))
 234                          )
 235                         ((setq ret (get-char-attribute char 'name*))
 236                          (setq char-spec (cons (cons 'name* ret) char-spec))
 237                          ))
 238                   )
 239                  ((setq ret
 240                         (catch 'tag
 241                           (let ((rest char-db-coded-charset-priority-list)
 242                                 ccs)
 243                             (while rest
 244                               (setq ccs (charset-name
 245                                          (find-charset (car rest))))
 246                               (if (setq ret
 247                                         (encode-char char ccs
 248                                                      'defined-only))
 249                                   (throw 'tag (cons ccs ret)))
 250                               (setq rest (cdr rest))))))
 251                   (setq char-spec (list ret))
 252                   (dolist (ccs (delq (car ret) (charset-list)))
 253                     (if (and (or (charset-iso-final-char ccs)
 254                                  (memq ccs
 255                                        '(=daikanwa
 256                                          =daikanwa@rev2
 257                                          ;; =gt-k
 258                                          =jis-x0208@1997
 259                                          )))
 260                              (setq ccs (charset-name ccs))
 261                              (null (assq ccs char-spec))
 262                              (setq ret (encode-char char ccs 'defined-only)))
 263                         (setq char-spec (cons (cons ccs ret) char-spec))))
 264                   (if (null char-spec)
 265                       (setq char-spec (split-char char)))
 266                   (cond ((setq ret (get-char-attribute char 'name))
 267                          (setq char-spec (cons (cons 'name ret) char-spec))
 268                          )
 269                         ((setq ret (get-char-attribute char 'name*))
 270                          (setq char-spec (cons (cons 'name* ret) char-spec))
 271                          ))
 272                   ))
 273            char-spec)
 274           ((consp char)
 275            char))))
 276
 277 (defun char-db-insert-char-spec (char &optional readable column
 278                                       required-features)
 279   (unless column
 280     (setq column (current-column)))
 281   (let (char-spec temp-char)
 282     (setq char-spec (char-db-make-char-spec char))
 283     (unless (or (characterp char) ; char
 284                 (condition-case nil
 285                     (setq char (find-char char-spec))
 286                   (error nil)))
 287       ;; define temporary character
 288       ;;   Current implementation is dirty.
 289       (setq temp-char (define-char (cons '(ideograph-daikanwa . 0)
 290                                          char-spec)))
 291       (remove-char-attribute temp-char 'ideograph-daikanwa)
 292       (setq char temp-char))
 293     (insert-char-attributes char
 294                             readable
 295                             (union (mapcar #'car char-spec)
 296                                    required-features))
 297     (when temp-char
 298       ;; undefine temporary character
 299       ;;   Current implementation is dirty.
 300       (setq char-spec (char-attribute-alist temp-char))
 301       (while char-spec
 302         (remove-char-attribute temp-char (car (car char-spec)))
 303         (setq char-spec (cdr char-spec))))))
 304
 305 (defun char-db-insert-alist (alist &optional readable column)
 306   (unless column
 307     (setq column (current-column)))
 308   (let ((line-breaking
 309          (concat "\n" (make-string (1+ column) ?\ )))
 310         name value
 311         ret al ; cal
 312         key
 313         lbs cell rest separator)
 314     (insert "(")
 315     (while alist
 316       (setq name (car (car alist))
 317             value (cdr (car alist)))
 318       (cond ((eq name 'char)
 319              (insert "(char . ")
 320              (if (setq ret (condition-case nil
 321                                (find-char value)
 322                              (error nil)))
 323                  (progn
 324                    (setq al nil
 325                          ;; cal nil
 326                          )
 327                    (while value
 328                      (setq key (car (car value)))
 329                      ;; (if (find-charset key)
 330                      ;;     (setq cal (cons key cal))
 331                      (setq al (cons key al))
 332                      ;; )
 333                      (setq value (cdr value)))
 334                    (insert-char-attributes ret
 335                                            readable
 336                                            (or al 'none) ; cal
 337                                            ))
 338                (insert (prin1-to-string value)))
 339              (insert ")")
 340              (insert line-breaking))
 341             ((consp value)
 342              (insert (format "(%-18s " name))
 343              (setq lbs (concat "\n" (make-string (current-column) ?\ )))
 344              (while (consp value)
 345                (setq cell (car value))
 346                (if (and (consp cell)
 347                         (consp (car cell))
 348                         (setq ret (condition-case nil
 349                                       (find-char cell)
 350                                     (error nil)))
 351                         )
 352                    (progn
 353                      (setq rest cell
 354                            al nil
 355                            ;; cal nil
 356                            )
 357                      (while rest
 358                        (setq key (car (car rest)))
 359                        ;; (if (find-charset key)
 360                        ;;     (setq cal (cons key cal))
 361                        (setq al (cons key al))
 362                        ;; )
 363                        (setq rest (cdr rest)))
 364                      (if separator
 365                          (insert lbs))
 366                      (insert-char-attributes ret
 367                                              readable
 368                                              al ; cal
 369                                              )
 370                      (setq separator lbs))
 371                  (if separator
 372                      (insert separator))
 373                  (insert (prin1-to-string cell))
 374                  (setq separator " "))
 375                (setq value (cdr value)))
 376              (insert ")")
 377              (insert line-breaking))
 378             (t
 379              (insert (format "(%-18s . %S)%s"
 380                              name value
 381                              line-breaking))))
 382       (setq alist (cdr alist))))
 383   (insert ")"))
 384
 385 (defun char-db-insert-char-reference (plist &optional readable column)
 386   (unless column
 387     (setq column (current-column)))
 388   (let ((line-breaking
 389          (concat "\n" (make-string (1+ column) ?\ )))
 390         (separator "")
 391         name value)
 392     (insert "(")
 393     (while plist
 394       (setq name (pop plist))
 395       (setq value (pop plist))
 396       (cond ((eq name :char)
 397              (insert separator)
 398              (insert ":char\t")
 399              (cond ((numberp value)
 400                     (setq value (decode-char '=ucs value)))
 401                    ;; ((consp value)
 402                    ;;  (setq value (or (find-char value)
 403                    ;;                  value)))
 404                    )
 405              (char-db-insert-char-spec value readable)
 406              (insert line-breaking)
 407              (setq separator ""))
 408             ((eq name :radical)
 409              (insert (format "%s%s\t%d ; %c%s"
 410                              separator
 411                              name value
 412                              (ideographic-radical value)
 413                              line-breaking))
 414              (setq separator ""))
 415             (t
 416              (insert (format "%s%s\t%S" separator name value))
 417              (setq separator line-breaking)))
 418       ))
 419   (insert ")"))
 420
 421 (defun char-db-decode-isolated-char (ccs code-point)
 422   (let (ret)
 423     (setq ret
 424           (cond ((eq ccs 'arabic-iso8859-6)
 425                  (decode-char ccs code-point))
 426                 ((and (memq ccs '(=gt-pj-1
 427                                   =gt-pj-2
 428                                   =gt-pj-3
 429                                   =gt-pj-4
 430                                   =gt-pj-5
 431                                   =gt-pj-6
 432                                   =gt-pj-7
 433                                   =gt-pj-8
 434                                   =gt-pj-9
 435                                   =gt-pj-10
 436                                   =gt-pj-11))
 437                       (setq ret (decode-char ccs code-point))
 438                       (setq ret (encode-char ret '=gt 'defined-only)))
 439                  (decode-builtin-char '=gt ret))
 440                 (t
 441                  (decode-builtin-char ccs code-point))))
 442     (cond ((and (<= 0 (char-int ret))
 443                 (<= (char-int ret) #x1F))
 444            (decode-char '=ucs (+ #x2400 (char-int ret))))
 445           ((= (char-int ret) #x7F)
 446            ?\u2421)
 447           (t ret))))
 448
 449 (defvar char-db-convert-obsolete-format t)
 450
 451 (defun char-db-insert-ccs-feature (name value line-breaking)
 452   (insert
 453    (format
 454     (cond ((or (memq name '(=daikanwa
 455                             =daikanwa@rev1 =daikanwa@rev2
 456                             =gt =gt-k =cbeta =zinbun-oracle))
 457                (string-match "^=adobe-" (symbol-name name)))
 458            "(%-18s . %05d)\t; %c")
 459           ((eq name 'mojikyo)
 460            "(%-18s . %06d)\t; %c")
 461           ((>= (charset-dimension name) 2)
 462            "(%-18s . #x%04X)\t; %c")
 463           (t
 464            "(%-18s . #x%02X)\t; %c"))
 465     name
 466     (if (= (charset-iso-graphic-plane name) 1)
 467         (logior value
 468                 (cond ((= (charset-dimension name) 1)
 469                        #x80)
 470                       ((= (charset-dimension name) 2)
 471                        #x8080)
 472                       ((= (charset-dimension name) 3)
 473                        #x808080)
 474                       (t 0)))
 475       value)
 476     (char-db-decode-isolated-char name value)))
 477   (if (and (= (charset-chars name) 94)
 478            (= (charset-dimension name) 2))
 479       (insert (format " [%02d-%02d]"
 480                       (- (lsh value -8) 32)
 481                       (- (logand value 255) 32))))
 482   (insert line-breaking))
 483
 484 (defun char-db-insert-relation-feature (char name value line-breaking
 485                                              ccss readable)
 486   (insert (format "(%-18s%s " name line-breaking))
 487   (let ((lbs (concat "\n" (make-string (current-column) ?\ )))
 488         separator cell sources required-features
 489         ret)
 490     (while (consp value)
 491       (setq cell (car value))
 492       (if (integerp cell)
 493           (setq cell (decode-char '=ucs cell)))
 494       (cond
 495        ((eq name '->subsumptive)
 496         (when (or (not (some (lambda (atr)
 497                                (get-char-attribute cell atr))
 498                              char-db-ignored-attributes))
 499                   (some (lambda (ccs)
 500                           (encode-char cell ccs 'defined-only))
 501                         ccss))
 502           (if separator
 503               (insert lbs))
 504           (let ((char-db-ignored-attributes
 505                  (cons '<-subsumptive
 506                        char-db-ignored-attributes)))
 507             (insert-char-attributes cell readable))
 508           (setq separator lbs))
 509         )
 510        ((characterp cell)
 511         (setq sources
 512               (get-char-attribute
 513                char (intern (format "%s*sources" name))))
 514         (setq required-features nil)
 515         (dolist (source sources)
 516           (cond
 517            ((memq source '(JP JP/Jouyou shinjigen-1))
 518             (setq required-features
 519                   (union required-features
 520                          '(=jis-x0208
 521                            =jis-x0208@1990
 522                            =jis-x0213-1-2000
 523                            =jis-x0213-2-2000
 524                            =jis-x0212
 525                            =jis-x0208@1983
 526                            =jis-x0208@1978))))
 527            ((eq source 'CN)
 528             (setq required-features
 529                   (union required-features
 530                          '(=gb2312
 531                            =gb12345
 532                            =iso-ir165)))))
 533           (cond
 534            ((find-charset (setq ret (intern (format "=%s" source))))
 535             (setq required-features
 536                   (cons ret required-features)))
 537            (t (setq required-features
 538                     (cons source required-features)))))
 539         (cond ((string-match "@JP" (symbol-name name))
 540                (setq required-features
 541                      (union required-features
 542                             '(=jis-x0208
 543                               =jis-x0208@1990
 544                               =jis-x0213-1-2000
 545                               =jis-x0213-2-2000
 546                               =jis-x0212
 547                               =jis-x0208@1983
 548                               =jis-x0208@1978))))
 549               ((string-match "@CN" (symbol-name name))
 550                (setq required-features
 551                      (union required-features
 552                             '(=gb2312
 553                               =gb12345
 554                               =iso-ir165)))))
 555         (if separator
 556             (insert lbs))
 557         (if readable
 558             (insert (format "%S" cell))
 559           (char-db-insert-char-spec cell readable
 560                                     nil
 561                                     required-features))
 562         (setq separator lbs))
 563        ((consp cell)
 564         (if separator
 565             (insert lbs))
 566         (if (consp (car cell))
 567             (char-db-insert-char-spec cell readable)
 568           (char-db-insert-char-reference cell readable))
 569         (setq separator lbs))
 570        (t
 571         (if separator
 572             (insert separator))
 573         (insert (prin1-to-string cell))
 574         (setq separator " ")))
 575       (setq value (cdr value)))
 576     (insert ")")
 577     (insert line-breaking)))
 578
 579 (defun insert-char-attributes (char &optional readable attributes column)
 580   (unless column
 581     (setq column (current-column)))
 582   (let (name value ; has-long-ccs-name
 583         rest
 584         radical strokes
 585         (line-breaking
 586          (concat "\n" (make-string (1+ column) ?\ )))
 587         lbs cell separator ret
 588         key al cal
 589         dest-ccss ; sources required-features
 590         ccss)
 591     (let (atr-d)
 592       (setq attributes
 593             (sort (if attributes
 594                       (if (consp attributes)
 595                           (progn
 596                             (dolist (name attributes)
 597                               (unless (memq name char-db-ignored-attributes)
 598                                 (if (find-charset name)
 599                                     (push name ccss))
 600                                 (push name atr-d)))
 601                             atr-d))
 602                     (dolist (name (char-attribute-list))
 603                       (unless (memq name char-db-ignored-attributes)
 604                         (if (find-charset name)
 605                             (push name ccss))
 606                         (push name atr-d)))
 607                     atr-d)
 608                   #'char-attribute-name<)))
 609     (insert "(")
 610     (when (memq '<-subsumptive attributes)
 611       (when readable
 612         (when (setq value (get-char-attribute char '<-subsumptive))
 613           (char-db-insert-relation-feature char '<-subsumptive value
 614                                            line-breaking
 615                                            ccss readable)))
 616       (setq attributes (delq '<-subsumptive attributes)))
 617     (when (and (memq '<-denotational attributes)
 618                (setq value (get-char-attribute char '<-denotational)))
 619       (char-db-insert-relation-feature char '<-denotational value
 620                                        line-breaking
 621                                        ccss readable)
 622       (setq attributes (delq '<-denotational attributes)))
 623     (when (and (memq 'name attributes)
 624                (setq value (get-char-attribute char 'name)))
 625       (insert (format
 626                (if (> (+ (current-column) (length value)) 48)
 627                    "(name . %S)%s"
 628                  "(name               . %S)%s")
 629                value line-breaking))
 630       (setq attributes (delq 'name attributes))
 631       )
 632     (when (and (memq 'name* attributes)
 633                (setq value (get-char-attribute char 'name*)))
 634       (insert (format
 635                (if (> (+ (current-column) (length value)) 48)
 636                    "(name* . %S)%s"
 637                  "(name*              . %S)%s")
 638                value line-breaking))
 639       (setq attributes (delq 'name* attributes))
 640       )
 641     (when (and (memq 'script attributes)
 642                (setq value (get-char-attribute char 'script)))
 643       (insert (format "(script\t\t%s)%s"
 644                       (mapconcat (function prin1-to-string)
 645                                  value " ")
 646                       line-breaking))
 647       (setq attributes (delq 'script attributes))
 648       )
 649     (dolist (name '(=>ucs =>ucs*))
 650       (when (and (memq name attributes)
 651                  (setq value (get-char-attribute char name)))
 652         (insert (format "(%-18s . #x%04X)\t; %c%s"
 653                         name value (decode-char '=ucs value)
 654                         line-breaking))
 655         (setq attributes (delq name attributes))))
 656     (dolist (name '(=>ucs@gb =>ucs@cns =>ucs@jis =>ucs@ks =>ucs@big5))
 657       (when (and (memq name attributes)
 658                  (setq value (get-char-attribute char name)))
 659         (insert (format "(%-18s . #x%04X)\t; %c%s"
 660                         name value
 661                         (decode-char (intern
 662                                       (concat "="
 663                                               (substring
 664                                                (symbol-name name) 2)))
 665                                      value)
 666                         line-breaking))
 667         (setq attributes (delq name attributes))
 668         ))
 669     (dolist (name '(=>daikanwa))
 670       (when (and (memq name attributes)
 671                  (setq value (get-char-attribute char name)))
 672         (insert
 673          (if (integerp value)
 674              (format "(%-18s . %05d)\t; %c%s"
 675                      name value (decode-char '=daikanwa value)
 676                      line-breaking)
 677            (format "(%-18s %s)\t; %c%s"
 678                    name
 679                    (mapconcat (function prin1-to-string)
 680                               value " ")
 681                    (char-representative-of-daikanwa char)
 682                    line-breaking)))
 683         (setq attributes (delq name attributes))))
 684     (when (and (memq 'general-category attributes)
 685                (setq value (get-char-attribute char 'general-category)))
 686       (insert (format
 687                "(general-category\t%s) ; %s%s"
 688                (mapconcat (lambda (cell)
 689                             (format "%S" cell))
 690                           value " ")
 691                (cond ((rassoc value unidata-normative-category-alist)
 692                       "Normative Category")
 693                      ((rassoc value unidata-informative-category-alist)
 694                       "Informative Category")
 695                      (t
 696                       "Unknown Category"))
 697                line-breaking))
 698       (setq attributes (delq 'general-category attributes))
 699       )
 700     (when (and (memq 'bidi-category attributes)
 701                (setq value (get-char-attribute char 'bidi-category)))
 702       (insert (format "(bidi-category\t. %S)%s"
 703                       value
 704                       line-breaking))
 705       (setq attributes (delq 'bidi-category attributes))
 706       )
 707     (unless (or (not (memq 'mirrored attributes))
 708                 (eq (setq value (get-char-attribute char 'mirrored 'empty))
 709                     'empty))
 710       (insert (format "(mirrored\t\t. %S)%s"
 711                       value
 712                       line-breaking))
 713       (setq attributes (delq 'mirrored attributes))
 714       )
 715     (cond
 716      ((and (memq 'decimal-digit-value attributes)
 717            (setq value (get-char-attribute char 'decimal-digit-value)))
 718       (insert (format "(decimal-digit-value . %S)%s"
 719                       value
 720                       line-breaking))
 721       (setq attributes (delq 'decimal-digit-value attributes))
 722       (when (and (memq 'digit-value attributes)
 723                  (setq value (get-char-attribute char 'digit-value)))
 724         (insert (format "(digit-value\t . %S)%s"
 725                         value
 726                         line-breaking))
 727         (setq attributes (delq 'digit-value attributes))
 728         )
 729       (when (and (memq 'numeric-value attributes)
 730                  (setq value (get-char-attribute char 'numeric-value)))
 731         (insert (format "(numeric-value\t . %S)%s"
 732                         value
 733                         line-breaking))
 734         (setq attributes (delq 'numeric-value attributes))
 735         )
 736       )
 737      (t
 738       (when (and (memq 'digit-value attributes)
 739                  (setq value (get-char-attribute char 'digit-value)))
 740         (insert (format "(digit-value\t. %S)%s"
 741                         value
 742                         line-breaking))
 743         (setq attributes (delq 'digit-value attributes))
 744         )
 745       (when (and (memq 'numeric-value attributes)
 746                  (setq value (get-char-attribute char 'numeric-value)))
 747         (insert (format "(numeric-value\t. %S)%s"
 748                         value
 749                         line-breaking))
 750         (setq attributes (delq 'numeric-value attributes))
 751         )))
 752     (when (and (memq 'iso-10646-comment attributes)
 753                (setq value (get-char-attribute char 'iso-10646-comment)))
 754       (insert (format "(iso-10646-comment\t. %S)%s"
 755                       value
 756                       line-breaking))
 757       (setq attributes (delq 'iso-10646-comment attributes))
 758       )
 759     (when (and (memq 'morohashi-daikanwa attributes)
 760                (setq value (get-char-attribute char 'morohashi-daikanwa)))
 761       (insert (format "(morohashi-daikanwa\t%s)%s"
 762                       (mapconcat (function prin1-to-string) value " ")
 763                       line-breaking))
 764       (setq attributes (delq 'morohashi-daikanwa attributes))
 765       )
 766     (setq radical nil
 767           strokes nil)
 768     (when (and (memq 'ideographic-radical attributes)
 769                (setq value (get-char-attribute char 'ideographic-radical)))
 770       (setq radical value)
 771       (insert (format "(ideographic-radical . %S)\t; %c%s"
 772                       radical
 773                       (ideographic-radical radical)
 774                       line-breaking))
 775       (setq attributes (delq 'ideographic-radical attributes))
 776       )
 777     (when (and (memq 'shuowen-radical attributes)
 778                (setq value (get-char-attribute char 'shuowen-radical)))
 779       (insert (format "(shuowen-radical\t. %S)\t; %c%s"
 780                       value
 781                       (shuowen-radical value)
 782                       line-breaking))
 783       (setq attributes (delq 'shuowen-radical attributes))
 784       )
 785     (let (key)
 786       (dolist (domain
 787                (append
 788                 char-db-feature-domains
 789                 (let (dest domain)
 790                   (dolist (feature (char-attribute-list))
 791                     (setq feature (symbol-name feature))
 792                     (when (string-match
 793                            "\\(radical\\|strokes\\)@\\([^@*]+\\)\\(\\*\\|$\\)"
 794                            feature)
 795                       (setq domain (intern (match-string 2 feature)))
 796                      (unless (memq domain dest)
 797                        (setq dest (cons domain dest)))))
 798                   (sort dest #'string<))))
 799         (setq key (intern (format "%s@%s" 'ideographic-radical domain)))
 800         (when (and (memq key attributes)
 801                    (setq value (get-char-attribute char key)))
 802           (setq radical value)
 803           (insert (format "(%s . %S)\t; %c%s"
 804                           key
 805                           radical
 806                           (ideographic-radical radical)
 807                           line-breaking))
 808           (setq attributes (delq key attributes))
 809           )
 810         (setq key (intern (format "%s@%s" 'ideographic-strokes domain)))
 811         (when (and (memq key attributes)
 812                    (setq value (get-char-attribute char key)))
 813           (setq strokes value)
 814           (insert (format "(%s . %S)%s"
 815                           key
 816                           strokes
 817                           line-breaking))
 818           (setq attributes (delq key attributes))
 819           )
 820         (setq key (intern (format "%s@%s" 'total-strokes domain)))
 821         (when (and (memq key attributes)
 822                    (setq value (get-char-attribute char key)))
 823           (insert (format "(%s       . %S)%s"
 824                           key
 825                           value
 826                           line-breaking))
 827           (setq attributes (delq key attributes))
 828           )
 829         (dolist (feature '(ideographic-radical
 830                            ideographic-strokes
 831                            total-strokes))
 832           (setq key (intern (format "%s@%s*sources" feature domain)))
 833           (when (and (memq key attributes)
 834                      (setq value (get-char-attribute char key)))
 835             (insert (format "(%s%s" key line-breaking))
 836             (dolist (cell value)
 837               (insert (format " %s" cell)))
 838             (insert ")")
 839             (insert line-breaking)
 840             (setq attributes (delq key attributes))
 841             ))
 842         ))
 843     (when (and (memq 'ideographic-strokes attributes)
 844                (setq value (get-char-attribute char 'ideographic-strokes)))
 845       (setq strokes value)
 846       (insert (format "(ideographic-strokes . %S)%s"
 847                       strokes
 848                       line-breaking))
 849       (setq attributes (delq 'ideographic-strokes attributes))
 850       )
 851     (when (and (memq 'kangxi-radical attributes)
 852                (setq value (get-char-attribute char 'kangxi-radical)))
 853       (unless (eq value radical)
 854         (insert (format "(kangxi-radical\t . %S)\t; %c%s"
 855                         value
 856                         (ideographic-radical value)
 857                         line-breaking))
 858         (or radical
 859             (setq radical value)))
 860       (setq attributes (delq 'kangxi-radical attributes))
 861       )
 862     (when (and (memq 'kangxi-strokes attributes)
 863                (setq value (get-char-attribute char 'kangxi-strokes)))
 864       (unless (eq value strokes)
 865         (insert (format "(kangxi-strokes\t . %S)%s"
 866                         value
 867                         line-breaking))
 868         (or strokes
 869             (setq strokes value)))
 870       (setq attributes (delq 'kangxi-strokes attributes))
 871       )
 872     (when (and (memq 'japanese-radical attributes)
 873                (setq value (get-char-attribute char 'japanese-radical)))
 874       (unless (eq value radical)
 875         (insert (format "(japanese-radical\t . %S)\t; %c%s"
 876                         value
 877                         (ideographic-radical value)
 878                         line-breaking))
 879         (or radical
 880             (setq radical value)))
 881       (setq attributes (delq 'japanese-radical attributes))
 882       )
 883     (when (and (memq 'japanese-strokes attributes)
 884                (setq value (get-char-attribute char 'japanese-strokes)))
 885       (unless (eq value strokes)
 886         (insert (format "(japanese-strokes\t . %S)%s"
 887                         value
 888                         line-breaking))
 889         (or strokes
 890             (setq strokes value)))
 891       (setq attributes (delq 'japanese-strokes attributes))
 892       )
 893     (when (and (memq 'cns-radical attributes)
 894                (setq value (get-char-attribute char 'cns-radical)))
 895       (insert (format "(cns-radical\t . %S)\t; %c%s"
 896                       value
 897                       (ideographic-radical value)
 898                       line-breaking))
 899       (setq attributes (delq 'cns-radical attributes))
 900       )
 901     (when (and (memq 'cns-strokes attributes)
 902                (setq value (get-char-attribute char 'cns-strokes)))
 903       (unless (eq value strokes)
 904         (insert (format "(cns-strokes\t . %S)%s"
 905                         value
 906                         line-breaking))
 907         (or strokes
 908             (setq strokes value)))
 909       (setq attributes (delq 'cns-strokes attributes))
 910       )
 911     (when (and (memq 'shinjigen-1-radical attributes)
 912                (setq value (get-char-attribute char 'shinjigen-1-radical)))
 913       (unless (eq value radical)
 914         (insert (format "(shinjigen-1-radical . %S)\t; %c%s"
 915                         value
 916                         (ideographic-radical value)
 917                         line-breaking))
 918         (or radical
 919             (setq radical value)))
 920       (setq attributes (delq 'shinjigen-1-radical attributes))
 921       )
 922     (when (and (memq 'ideographic- attributes)
 923                (setq value (get-char-attribute char 'ideographic-)))
 924       (insert "(ideographic-       ")
 925       (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 926             separator nil)
 927       (while (consp value)
 928         (setq cell (car value))
 929         (if (integerp cell)
 930             (setq cell (decode-char '=ucs cell)))
 931         (cond ((characterp cell)
 932                (if separator
 933                    (insert lbs))
 934                (if readable
 935                    (insert (format "%S" cell))
 936                  (char-db-insert-char-spec cell readable))
 937                (setq separator lbs))
 938               ((consp cell)
 939                (if separator
 940                    (insert lbs))
 941                (if (consp (car cell))
 942                    (char-db-insert-char-spec cell readable)
 943                  (char-db-insert-char-reference cell readable))
 944                (setq separator lbs))
 945               (t
 946                (if separator
 947                    (insert separator))
 948                (insert (prin1-to-string cell))
 949                (setq separator " ")))
 950         (setq value (cdr value)))
 951       (insert ")")
 952       (insert line-breaking)
 953       (setq attributes (delq 'ideographic- attributes)))
 954     (when (and (memq 'total-strokes attributes)
 955                (setq value (get-char-attribute char 'total-strokes)))
 956       (insert (format "(total-strokes       . %S)%s"
 957                       value
 958                       line-breaking))
 959       (setq attributes (delq 'total-strokes attributes))
 960       )
 961     (when (and (memq '->ideograph attributes)
 962                (setq value (get-char-attribute char '->ideograph)))
 963       (insert (format "(->ideograph\t%s)%s"
 964                       (mapconcat (lambda (code)
 965                                    (cond ((symbolp code)
 966                                           (symbol-name code))
 967                                          ((integerp code)
 968                                           (format "#x%04X" code))
 969                                          (t
 970                                           (format "%s %S"
 971                                                   line-breaking code))))
 972                                  value " ")
 973                       line-breaking))
 974       (setq attributes (delq '->ideograph attributes))
 975       )
 976     ;; (when (and (memq '->decomposition attributes)
 977     ;;            (setq value (get-char-attribute char '->decomposition)))
 978     ;;   (insert (format "(->decomposition\t%s)%s"
 979     ;;                   (mapconcat (lambda (code)
 980     ;;                                (cond ((symbolp code)
 981     ;;                                       (symbol-name code))
 982     ;;                                      ((characterp code)
 983     ;;                                       (if readable
 984     ;;                                           (format "%S" code)
 985     ;;                                         (format "#x%04X"
 986     ;;                                                 (char-int code))
 987     ;;                                         ))
 988     ;;                                      ((integerp code)
 989     ;;                                       (format "#x%04X" code))
 990     ;;                                      (t
 991     ;;                                       (format "%s%S" line-breaking code))))
 992     ;;                              value " ")
 993     ;;                   line-breaking))
 994     ;;   (setq attributes (delq '->decomposition attributes))
 995     ;;   )
 996     (if (equal (get-char-attribute char '->titlecase)
 997                (get-char-attribute char '->uppercase))
 998         (setq attributes (delq '->titlecase attributes)))
 999     (when (and (memq '->mojikyo attributes)
1000                (setq value (get-char-attribute char '->mojikyo)))
1001       (insert (format "(->mojikyo\t\t. %06d)\t; %c%s"
1002                       value (decode-char 'mojikyo value)
1003                       line-breaking))
1004       (setq attributes (delq '->mojikyo attributes))
1005       )
1006     (when (and (memq 'hanyu-dazidian-vol attributes)
1007                (setq value (get-char-attribute char 'hanyu-dazidian-vol)))
1008       (insert (format "(hanyu-dazidian-vol  . %d)%s"
1009                       value line-breaking))
1010       (setq attributes (delq 'hanyu-dazidian-vol attributes))
1011       )
1012     (when (and (memq 'hanyu-dazidian-page attributes)
1013                (setq value (get-char-attribute char 'hanyu-dazidian-page)))
1014       (insert (format "(hanyu-dazidian-page . %d)%s"
1015                       value line-breaking))
1016       (setq attributes (delq 'hanyu-dazidian-page attributes))
1017       )
1018     (when (and (memq 'hanyu-dazidian-char attributes)
1019                (setq value (get-char-attribute char 'hanyu-dazidian-char)))
1020       (insert (format "(hanyu-dazidian-char . %d)%s"
1021                       value line-breaking))
1022       (setq attributes (delq 'hanyu-dazidian-char attributes))
1023       )
1024     (unless readable
1025       (dolist (ignored '(composition
1026                          ->denotational <-subsumptive ->ucs-unified
1027                          ->ideographic-component-forms))
1028         (setq attributes (delq ignored attributes))))
1029     (while attributes
1030       (setq name (car attributes))
1031       (if (setq value (get-char-attribute char name))
1032           (cond ((setq ret (find-charset name))
1033                  (setq name (charset-name ret))
1034                  (if (and (not (memq name dest-ccss))
1035                           (prog1
1036                               (setq value (get-char-attribute char name))
1037                             (setq dest-ccss (cons name dest-ccss))))
1038                      (char-db-insert-ccs-feature name value line-breaking))
1039                  )
1040                 ((string-match "^=>ucs@" (symbol-name name))
1041                  (insert (format "(%-18s . #x%04X)\t; %c%s"
1042                                  name value (decode-char '=ucs value)
1043                                  line-breaking))
1044                  )
1045                 ((eq name 'jisx0208-1978/4X)
1046                  (insert (format "(%-18s . #x%04X)%s"
1047                                  name value
1048                                  line-breaking))
1049                  )
1050                 ((and
1051                   (not readable)
1052                   (not (eq name '->subsumptive))
1053                   (not (eq name '->uppercase))
1054                   (not (eq name '->lowercase))
1055                   (not (eq name '->titlecase))
1056                   (not (eq name '->canonical))
1057                   (not (eq name '->Bopomofo))
1058                   (not (eq name '->mistakable))
1059                   (not (eq name '->ideographic-variants))
1060                   (null (get-char-attribute
1061                          char (intern (format "%s*sources" name))))
1062                   (not (string-match "\\*sources$" (symbol-name name)))
1063                   (null (get-char-attribute
1064                          char (intern (format "%s*note" name))))
1065                   (not (string-match "\\*note$" (symbol-name name)))
1066                   (or (eq name '<-identical)
1067                       (eq name '<-uppercase)
1068                       (eq name '<-lowercase)
1069                       (eq name '<-titlecase)
1070                       (eq name '<-canonical)
1071                       (eq name '<-ideographic-variants)
1072                       ;; (eq name '<-synonyms)
1073                       (string-match "^<-synonyms" (symbol-name name))
1074                       (eq name '<-mistakable)
1075                       (when (string-match "^->" (symbol-name name))
1076                         (cond
1077                          ((string-match "^->fullwidth" (symbol-name name))
1078                           (not (and (consp value)
1079                                     (characterp (car value))
1080                                     (encode-char
1081                                      (car value) '=ucs 'defined-only)))
1082                           )
1083                          (t)))
1084                       ))
1085                  )
1086                 ((or (eq name 'ideographic-structure)
1087                      (eq name 'ideographic-combination)
1088                      (eq name 'ideographic-)
1089                      (eq name '=decomposition)
1090                      (string-match "^=>decomposition" (symbol-name name))
1091                      (string-match "^\\(->\\|<-\\)[^*]*$" (symbol-name name))
1092                      (string-match "^\\(->\\|<-\\)[^*]*\\*sources$"
1093                                    (symbol-name name))
1094                      )
1095                  (char-db-insert-relation-feature char name value
1096                                                   line-breaking
1097                                                   ccss readable))
1098                 ((memq name '(ideograph=
1099                               original-ideograph-of
1100                               ancient-ideograph-of
1101                               vulgar-ideograph-of
1102                               wrong-ideograph-of
1103                               ;; simplified-ideograph-of
1104                               ideographic-variants
1105                               ;; ideographic-different-form-of
1106                               ))
1107                  (insert (format "(%-18s%s " name line-breaking))
1108                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
1109                        separator nil)
1110                  (while (consp value)
1111                    (setq cell (car value))
1112                    (if (and (consp cell)
1113                             (consp (car cell)))
1114                        (progn
1115                          (if separator
1116                              (insert lbs))
1117                          (char-db-insert-alist cell readable)
1118                          (setq separator lbs))
1119                      (if separator
1120                          (insert separator))
1121                      (insert (prin1-to-string cell))
1122                      (setq separator " "))
1123                    (setq value (cdr value)))
1124                  (insert ")")
1125                  (insert line-breaking))
1126                 ((consp value)
1127                  (insert (format "(%-18s " name))
1128                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
1129                        separator nil)
1130                  (while (consp value)
1131                    (setq cell (car value))
1132                    (if (and (consp cell)
1133                             (consp (car cell))
1134                             (setq ret (condition-case nil
1135                                           (find-char cell)
1136                                         (error nil))))
1137                        (progn
1138                          (setq rest cell
1139                                al nil
1140                                cal nil)
1141                          (while rest
1142                            (setq key (car (car rest)))
1143                            (if (find-charset key)
1144                                (setq cal (cons key cal))
1145                              (setq al (cons key al)))
1146                            (setq rest (cdr rest)))
1147                          (if separator
1148                              (insert lbs))
1149                          (insert-char-attributes ret
1150                                                  readable
1151                                                  al cal)
1152                          (setq separator lbs))
1153                      (setq ret (prin1-to-string cell))
1154                      (if separator
1155                          (if (< (+ (current-column)
1156                                    (length ret)
1157                                    (length separator))
1158                                 76)
1159                              (insert separator)
1160                            (insert lbs)))
1161                      (insert ret)
1162                      (setq separator " "))
1163                    (setq value (cdr value)))
1164                  (insert ")")
1165                  (insert line-breaking))
1166                 (t
1167                  (insert (format "(%-18s" name))
1168                  (setq ret (prin1-to-string value))
1169                  (unless (< (+ (current-column)
1170                                (length ret)
1171                                3)
1172                             76)
1173                    (insert line-breaking))
1174                  (insert " . " ret ")" line-breaking)
1175                  ;; (insert (format "(%-18s . %S)%s"
1176                  ;;                 name value
1177                  ;;                 line-breaking))
1178                  )
1179                 ))
1180       (setq attributes (cdr attributes)))
1181     (insert ")")))
1182
1183 (defun insert-char-data (char &optional readable
1184                               attributes)
1185   (save-restriction
1186     (narrow-to-region (point)(point))
1187     (insert "(define-char
1188   '")
1189     (insert-char-attributes char readable attributes)
1190     (insert ")\n")
1191     (goto-char (point-min))
1192     (while (re-search-forward "[ \t]+$" nil t)
1193       (replace-match ""))
1194     ;; from tabify.
1195     (goto-char (point-min))
1196     (while (re-search-forward "[ \t][ \t][ \t]*" nil t)
1197       (let ((column (current-column))
1198             (indent-tabs-mode t))
1199         (delete-region (match-beginning 0) (point))
1200         (indent-to column)))
1201     (goto-char (point-max))
1202     ;; (tabify (point-min)(point-max))
1203     ))
1204
1205 (defun insert-char-data-with-variant (char &optional printable
1206                                            no-ucs-unified
1207                                            script excluded-script)
1208   (insert-char-data char printable)
1209   (let ((variants (char-variants char))
1210         rest
1211         variant vs ret)
1212     (setq variants (sort variants #'<))
1213     (setq rest variants)
1214     (setq variants (cons char variants))
1215     (while rest
1216       (setq variant (car rest))
1217       (unless (get-char-attribute variant '<-subsumptive)
1218         (if (and (or (null script)
1219                      (null (setq vs (get-char-attribute variant 'script)))
1220                      (memq script vs))
1221                  (or (null excluded-script)
1222                      (null (setq vs (get-char-attribute variant 'script)))
1223                      (not (memq excluded-script vs))))
1224             (unless (and no-ucs-unified (get-char-attribute variant '=ucs))
1225               (insert-char-data variant printable)
1226               (if (setq ret (char-variants variant))
1227                   (while ret
1228                     (or (memq (car ret) variants)
1229                         ;; (get-char-attribute (car ret) '<-subsumptive)
1230                         (setq rest (nconc rest (list (car ret)))))
1231                     (setq ret (cdr ret)))))))
1232       (setq rest (cdr rest)))))
1233
1234 (defun insert-char-range-data (min max &optional script excluded-script)
1235   (let ((code min)
1236         char)
1237     (while (<= code max)
1238       (setq char (decode-char '=ucs code))
1239       (if (encode-char char '=ucs 'defined-only)
1240           (insert-char-data-with-variant char nil 'no-ucs-unified
1241                                          script excluded-script))
1242       (setq code (1+ code)))))
1243
1244 (defun write-char-range-data-to-file (min max file
1245                                           &optional script excluded-script)
1246   (let ((coding-system-for-write char-db-file-coding-system))
1247     (with-temp-buffer
1248       (insert (format ";; -*- coding: %s -*-\n"
1249                       char-db-file-coding-system))
1250       (insert-char-range-data min max script excluded-script)
1251       (write-region (point-min)(point-max) file))))
1252
1253 (defvar what-character-original-window-configuration)
1254
1255 ;;;###autoload
1256 (defun what-char-definition (char)
1257   (interactive (list (char-after)))
1258   (let ((buf (get-buffer-create "*Character Description*"))
1259         (the-buf (current-buffer))
1260         (win-conf (current-window-configuration)))
1261     (pop-to-buffer buf)
1262     (make-local-variable 'what-character-original-window-configuration)
1263     (setq what-character-original-window-configuration win-conf)
1264     (setq buffer-read-only nil)
1265     (erase-buffer)
1266     (condition-case err
1267         (progn
1268           (insert-char-data-with-variant char 'printable)
1269           (unless (char-attribute-alist char)
1270             (insert (format ";; = %c\n"
1271                             (let* ((rest (split-char char))
1272                                    (ccs (pop rest))
1273                                    (code (pop rest)))
1274                               (while rest
1275                                 (setq code (logior (lsh code 8)
1276                                                    (pop rest))))
1277                               (decode-char ccs code)))))
1278           ;; (char-db-update-comment)
1279           (set-buffer-modified-p nil)
1280           (view-mode the-buf (lambda (buf)
1281                                (set-window-configuration
1282                                 what-character-original-window-configuration)
1283                                ))
1284           (goto-char (point-min)))
1285       (error (progn
1286                (set-window-configuration
1287                 what-character-original-window-configuration)
1288                (signal (car err) (cdr err)))))))
1289
1290 (provide 'char-db-util)
1291
1292 ;;; char-db-util.el ends here