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

   1 ;;; char-db-util.el --- Character Database utility
   2
   3 ;; Copyright (C) 1998,1999,2000,2001 MORIOKA Tomohiko.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: UTF-2000, ISO/IEC 10646, Unicode, UCS-4, MULE.
   7
   8 ;; This file is part of UTF-2000.
   9
  10 ;; UTF-2000 is free software; you can redistribute it and/or modify it
  11 ;; under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; UTF-2000 is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  23 ;; 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (require 'alist)
  28
  29 (defconst unidata-normative-category-alist
  30   '(("Lu" letter        uppercase)
  31     ("Ll" letter        lowercase)
  32     ("Lt" letter        titlecase)
  33     ("Mn" mark          non-spacing)
  34     ("Mc" mark          spacing-combining)
  35     ("Me" mark          enclosing)
  36     ("Nd" number        decimal-digit)
  37     ("Nl" number        letter)
  38     ("No" number        other)
  39     ("Zs" separator     space)
  40     ("Zl" separator     line)
  41     ("Zp" separator     paragraph)
  42     ("Cc" other         control)
  43     ("Cf" other         format)
  44     ("Cs" other         surrogate)
  45     ("Co" other         private-use)
  46     ("Cn" other         not-assigned)))
  47
  48 (defconst unidata-informative-category-alist
  49   '(("Lm" letter        modifier)
  50     ("Lo" letter        other)
  51     ("Pc" punctuation   connector)
  52     ("Pd" punctuation   dash)
  53     ("Ps" punctuation   open)
  54     ("Pe" punctuation   close)
  55     ("Pi" punctuation   initial-quote)
  56     ("Pf" punctuation   final-quote)
  57     ("Po" punctuation   other)
  58     ("Sm" symbol        math)
  59     ("Sc" symbol        currency)
  60     ("Sk" symbol        modifier)
  61     ("So" symbol        other)
  62     ))
  63
  64 (defconst ideographic-radicals
  65   (let ((v (make-vector 215 nil))
  66         (i 1))
  67     (while (< i 215)
  68       (aset v i (int-char (+ #x2EFF i)))
  69       (setq i (1+ i)))
  70     (if (< (charset-iso-final-char (car (split-char (aref v 34)))) ?0)
  71         (aset v 34 (make-char 'chinese-gb2312 #x62 #x3A)))
  72     v))
  73
  74 (defun char-attribute-name< (ka kb)
  75   (cond
  76    ((find-charset ka)
  77     (cond
  78      ((find-charset kb)
  79       (cond
  80        ((= (charset-dimension ka)
  81            (charset-dimension kb))
  82         (cond ((= (charset-chars ka)(charset-chars kb))
  83                (cond
  84                 ((>= (charset-iso-final-char ka) ?@)
  85                  (if (>= (charset-iso-final-char kb) ?@)
  86                      (< (charset-iso-final-char ka)
  87                         (charset-iso-final-char kb))
  88                    t))
  89                 ((>= (charset-iso-final-char ka) ?0)
  90                  (cond
  91                   ((>= (charset-iso-final-char kb) ?@)
  92                    nil)
  93                   ((>= (charset-iso-final-char kb) ?0)
  94                    (< (charset-iso-final-char ka)
  95                       (charset-iso-final-char kb)))
  96                   (t)))))
  97               ((<= (charset-chars ka)(charset-chars kb)))))
  98        (t
  99         (< (charset-dimension ka)
 100            (charset-dimension kb))
 101         )))
 102      ((symbolp kb)
 103       nil)
 104      (t
 105       t)))
 106    ((find-charset kb)
 107     t)
 108    ((symbolp ka)
 109     (cond ((symbolp kb)
 110            (string< (symbol-name ka)
 111                     (symbol-name kb)))
 112           (t)))
 113    ((symbolp kb)
 114     nil)))
 115
 116 (defun char-db-insert-alist (alist &optional readable column)
 117   (unless column
 118     (setq column (current-column)))
 119   (let ((line-breaking
 120          (concat "\n" (make-string (1+ column) ?\ )))
 121         name value
 122         ret al cal key
 123         lbs cell rest separator)
 124     (insert "(")
 125     (while alist
 126       (setq name (car (car alist))
 127             value (cdr (car alist)))
 128       (cond ((eq name 'char)
 129              (insert "(char . ")
 130              (if (setq ret (condition-case nil
 131                                (define-char value)
 132                              (error nil)))
 133                  (progn
 134                    (setq al nil
 135                          cal nil)
 136                    (while value
 137                      (setq key (car (car value)))
 138                      (if (find-charset key)
 139                          (setq cal (cons key cal))
 140                        (setq al (cons key al)))
 141                      (setq value (cdr value)))
 142                    (insert-char-attributes ret
 143                                            readable
 144                                            al cal))
 145                (insert (prin1-to-string value)))
 146              (insert ")")
 147              (insert line-breaking))
 148             ((consp value)
 149              (insert (format "(%-18s " name))
 150              (setq lbs (concat "\n" (make-string (current-column) ?\ )))
 151              (while (consp value)
 152                (setq cell (car value))
 153                (if (and (consp cell)
 154                         (consp (car cell))
 155                         (setq ret (condition-case nil
 156                                       (define-char cell)
 157                                     (error nil)))
 158                         )
 159                    (progn
 160                      (setq rest cell
 161                            al nil
 162                            cal nil)
 163                      (while rest
 164                        (setq key (car (car rest)))
 165                        (if (find-charset key)
 166                            (setq cal (cons key cal))
 167                          (setq al (cons key al)))
 168                        (setq rest (cdr rest)))
 169                      (if separator
 170                          (insert lbs))
 171                      (insert-char-attributes ret
 172                                              readable
 173                                              al cal)
 174                      (setq separator lbs))
 175                  (if separator
 176                      (insert separator))
 177                  (insert (prin1-to-string cell))
 178                  (setq separator " "))
 179                (setq value (cdr value)))
 180              (insert ")")
 181              (insert line-breaking))
 182             (t
 183              (insert (format "(%-18s . %S)%s"
 184                              name value
 185                              line-breaking))))
 186       (setq alist (cdr alist))))
 187   (insert ")"))
 188
 189 (defun insert-char-attributes (char &optional readable
 190                                     attributes ccs-attributes
 191                                     column)
 192   (setq attributes
 193         (if attributes
 194             (copy-sequence attributes)
 195           (sort (char-attribute-list) #'char-attribute-name<)))
 196   (setq ccs-attributes
 197         (if ccs-attributes
 198             (copy-sequence ccs-attributes)
 199           (sort (charset-list) #'char-attribute-name<)))
 200   (unless column
 201     (setq column (current-column)))
 202   (let (name value has-long-ccs-name rest
 203         radical strokes
 204         (line-breaking
 205          (concat "\n" (make-string (1+ column) ?\ )))
 206         lbs cell separator ret
 207         key al cal)
 208     (insert "(")
 209     (when (and (memq 'name attributes)
 210                (setq value (get-char-attribute char 'name)))
 211       (insert (format
 212                (if (> (length value) 47)
 213                    "(name . %S)%s"
 214                  "(name\t\t. %S)%s")
 215                value line-breaking))
 216       (setq attributes (delq 'name attributes))
 217       )
 218     (when (and (memq 'script attributes)
 219                (setq value (get-char-attribute char 'script)))
 220       (insert (format "(script\t\t%s)%s"
 221                       (mapconcat (function prin1-to-string)
 222                                  value " ")
 223                       line-breaking))
 224       (setq attributes (delq 'script attributes))
 225       )
 226     (when (and (memq '->ucs attributes)
 227                (setq value (get-char-attribute char '->ucs)))
 228       (insert (format "(->ucs\t\t. #x%04X)\t; %c%s"
 229                       value (decode-char 'ucs value)
 230                       line-breaking))
 231       (setq attributes (delq '->ucs attributes))
 232       )
 233     (when (and (memq 'general-category attributes)
 234                (setq value (get-char-attribute char 'general-category)))
 235       (insert (format
 236                "(general-category\t%s) ; %s%s"
 237                (mapconcat (lambda (cell)
 238                             (format "%S" cell))
 239                           value " ")
 240                (cond ((rassoc value unidata-normative-category-alist)
 241                       "Normative Category")
 242                      ((rassoc value unidata-informative-category-alist)
 243                       "Informative Category")
 244                      (t
 245                       "Unknown Category"))
 246                line-breaking))
 247       (setq attributes (delq 'general-category attributes))
 248       )
 249     (when (and (memq 'bidi-category attributes)
 250                (setq value (get-char-attribute char 'bidi-category)))
 251       (insert (format "(bidi-category\t. %S)%s"
 252                       value
 253                       line-breaking))
 254       (setq attributes (delq 'bidi-category attributes))
 255       )
 256     (unless (or (not (memq 'mirrored attributes))
 257                 (eq (setq value (get-char-attribute char 'mirrored 'empty))
 258                     'empty))
 259       (insert (format "(mirrored\t\t. %S)%s"
 260                       value
 261                       line-breaking))
 262       (setq attributes (delq 'mirrored attributes))
 263       )
 264     (cond
 265      ((and (memq 'decimal-digit-value attributes)
 266            (setq value (get-char-attribute char 'decimal-digit-value)))
 267       (insert (format "(decimal-digit-value . %S)%s"
 268                       value
 269                       line-breaking))
 270       (setq attributes (delq 'decimal-digit-value attributes))
 271       (when (and (memq 'digit-value attributes)
 272                  (setq value (get-char-attribute char 'digit-value)))
 273         (insert (format "(digit-value\t . %S)%s"
 274                         value
 275                         line-breaking))
 276         (setq attributes (delq 'digit-value attributes))
 277         )
 278       (when (and (memq 'numeric-value attributes)
 279                  (setq value (get-char-attribute char 'numeric-value)))
 280         (insert (format "(numeric-value\t . %S)%s"
 281                         value
 282                         line-breaking))
 283         (setq attributes (delq 'numeric-value attributes))
 284         )
 285       )
 286      (t
 287       (when (and (memq 'digit-value attributes)
 288                  (setq value (get-char-attribute char 'digit-value)))
 289         (insert (format "(digit-value\t. %S)%s"
 290                         value
 291                         line-breaking))
 292         (setq attributes (delq 'digit-value attributes))
 293         )
 294       (when (and (memq 'numeric-value attributes)
 295                  (setq value (get-char-attribute char 'numeric-value)))
 296         (insert (format "(numeric-value\t. %S)%s"
 297                         value
 298                         line-breaking))
 299         (setq attributes (delq 'numeric-value attributes))
 300         )))
 301     (when (and (memq 'iso-10646-comment attributes)
 302                (setq value (get-char-attribute char 'iso-10646-comment)))
 303       (insert (format "(iso-10646-comment\t. %S)%s"
 304                       value
 305                       line-breaking))
 306       (setq attributes (delq 'iso-10646-comment attributes))
 307       )
 308     (when (and (memq 'morohashi-daikanwa attributes)
 309                (setq value (get-char-attribute char 'morohashi-daikanwa)))
 310       (insert (format "(morohashi-daikanwa\t%s)%s"
 311                       (mapconcat (function prin1-to-string) value " ")
 312                       line-breaking))
 313       (setq attributes (delq 'morohashi-daikanwa attributes))
 314       )
 315     (setq radical nil
 316           strokes nil)
 317     (when (and (memq 'ideographic-radical attributes)
 318                (setq value (get-char-attribute char 'ideographic-radical)))
 319       (setq radical value)
 320       (insert (format "(ideographic-radical . %S)\t; %c%s"
 321                       radical
 322                       (aref ideographic-radicals radical)
 323                       line-breaking))
 324       (setq attributes (delq 'ideographic-radical attributes))
 325       )
 326     (when (and (memq 'ideographic-strokes attributes)
 327                (setq value (get-char-attribute char 'ideographic-strokes)))
 328       (setq strokes value)
 329       (insert (format "(ideographic-strokes . %S)%s"
 330                       strokes
 331                       line-breaking))
 332       (setq attributes (delq 'ideographic-strokes attributes))
 333       )
 334     (when (and (memq 'kangxi-radical attributes)
 335                (setq value (get-char-attribute char 'kangxi-radical)))
 336       (unless (eq value radical)
 337         (insert (format "(kangxi-radical\t . %S)\t; %c%s"
 338                         value
 339                         (aref ideographic-radicals value)
 340                         line-breaking))
 341         (or radical
 342             (setq radical value)))
 343       (setq attributes (delq 'kangxi-radical attributes))
 344       )
 345     (when (and (memq 'kangxi-strokes attributes)
 346                (setq value (get-char-attribute char 'kangxi-strokes)))
 347       (unless (eq value strokes)
 348         (insert (format "(kangxi-strokes\t . %S)%s"
 349                         value
 350                         line-breaking))
 351         (or strokes
 352             (setq strokes value)))
 353       (setq attributes (delq 'kangxi-strokes attributes))
 354       )
 355     (when (and (memq 'japanese-radical attributes)
 356                (setq value (get-char-attribute char 'japanese-radical)))
 357       (unless (eq value radical)
 358         (insert (format "(japanese-radical\t . %S)\t; %c%s"
 359                         value
 360                         (aref ideographic-radicals value)
 361                         line-breaking))
 362         (or radical
 363             (setq radical value)))
 364       (setq attributes (delq 'japanese-radical attributes))
 365       )
 366     (when (and (memq 'japanese-strokes attributes)
 367                (setq value (get-char-attribute char 'japanese-strokes)))
 368       (unless (eq value strokes)
 369         (insert (format "(japanese-strokes\t . %S)%s"
 370                         value
 371                         line-breaking))
 372         (or strokes
 373             (setq strokes value)))
 374       (setq attributes (delq 'japanese-strokes attributes))
 375       )
 376     (when (and (memq 'cns-radical attributes)
 377                (setq value (get-char-attribute char 'cns-radical)))
 378       (insert (format "(cns-radical\t . %S)\t; %c%s"
 379                       value
 380                       (aref ideographic-radicals value)
 381                       line-breaking))
 382       (setq attributes (delq 'cns-radical attributes))
 383       )
 384     (when (and (memq 'cns-strokes attributes)
 385                (setq value (get-char-attribute char 'cns-strokes)))
 386       (unless (eq value strokes)
 387         (insert (format "(cns-strokes\t . %S)%s"
 388                         value
 389                         line-breaking))
 390         (or strokes
 391             (setq strokes value)))
 392       (setq attributes (delq 'cns-strokes attributes))
 393       )
 394     (when (and (memq 'shinjigen-1-radical attributes)
 395                (setq value (get-char-attribute char 'shinjigen-1-radical)))
 396       (unless (eq value radical)
 397         (insert (format "(shinjigen-1-radical . %S)\t; %c%s"
 398                         value
 399                         (aref ideographic-radicals value)
 400                         line-breaking))
 401         (or radical
 402             (setq radical value)))
 403       (setq attributes (delq 'shinjigen-1-radical attributes))
 404       )
 405     (when (and (memq 'total-strokes attributes)
 406                (setq value (get-char-attribute char 'total-strokes)))
 407       (insert (format "(total-strokes       . %S)%s"
 408                       value
 409                       line-breaking))
 410       (setq attributes (delq 'total-strokes attributes))
 411       )
 412     (when (and (memq '->ideograph attributes)
 413                (setq value (get-char-attribute char '->ideograph)))
 414       (insert (format "(->ideograph\t%s)%s"
 415                       (mapconcat (lambda (code)
 416                                    (cond ((symbolp code)
 417                                           (symbol-name code))
 418                                          ((integerp code)
 419                                           (format "#x%04X" code))
 420                                          (t
 421                                           (format "%s%S" line-breaking code))))
 422                                  value " ")
 423                       line-breaking))
 424       (setq attributes (delq '->ideograph attributes))
 425       )
 426     (when (and (memq '->decomposition attributes)
 427                (setq value (get-char-attribute char '->decomposition)))
 428       (insert (format "(->decomposition\t%s)%s"
 429                       (mapconcat (lambda (code)
 430                                    (cond ((symbolp code)
 431                                           (symbol-name code))
 432                                          ((characterp code)
 433                                           (if readable
 434                                               (format "%S" code)
 435                                             (format "#x%04X"
 436                                                     (char-int code))
 437                                             ))
 438                                          ((integerp code)
 439                                           (format "#x%04X" code))
 440                                          (t
 441                                           (format "%s%S" line-breaking code))))
 442                                  value " ")
 443                       line-breaking))
 444       (setq attributes (delq '->decomposition attributes))
 445       )
 446     (when (and (memq '->uppercase attributes)
 447                (setq value (get-char-attribute char '->uppercase)))
 448       (insert (format "(->uppercase\t%s)%s"
 449                       (mapconcat (lambda (code)
 450                                    (cond ((symbolp code)
 451                                           (symbol-name code))
 452                                          ((integerp code)
 453                                           (format "#x%04X" code))
 454                                          (t
 455                                           (format "%s%S" line-breaking code))))
 456                                  value " ")
 457                       line-breaking))
 458       (setq attributes (delq '->uppercase attributes))
 459       )
 460     (when (and (memq '->lowercase attributes)
 461                (setq value (get-char-attribute char '->lowercase)))
 462       (insert (format "(->lowercase\t%s)%s"
 463                       (mapconcat (lambda (code)
 464                                    (cond ((symbolp code)
 465                                           (symbol-name code))
 466                                          ((integerp code)
 467                                           (format "#x%04X" code))
 468                                          (t
 469                                           (format "%s%S" line-breaking code))))
 470                                  value " ")
 471                       line-breaking))
 472       (setq attributes (delq '->lowercase attributes))
 473       )
 474     (when (and (memq '->titlecase attributes)
 475                (setq value (get-char-attribute char '->titlecase)))
 476       (insert (format "(->titlecase\t%s)%s"
 477                       (mapconcat (lambda (code)
 478                                    (cond ((symbolp code)
 479                                           (symbol-name code))
 480                                          ((integerp code)
 481                                           (format "#x%04X" code))
 482                                          (t
 483                                           (format "%s%S" line-breaking code))))
 484                                  value " ")
 485                       line-breaking))
 486       (setq attributes (delq '->titlecase attributes))
 487       )
 488     (when (and (memq '->mojikyo attributes)
 489                (setq value (get-char-attribute char '->mojikyo)))
 490       (insert (format "(->mojikyo\t\t. %06d)\t; %c%s"
 491                       value (decode-char 'mojikyo value)
 492                       line-breaking))
 493       (setq attributes (delq '->mojikyo attributes))
 494       )
 495     (setq rest ccs-attributes)
 496     (while (and rest
 497                 (progn
 498                   (setq value (get-char-attribute char (car rest)))
 499                   (if value
 500                       (if (>= (length (symbol-name (car rest))) 19)
 501                           (progn
 502                             (setq has-long-ccs-name t)
 503                             nil)
 504                         t)
 505                     t)))
 506       (setq rest (cdr rest)))
 507     (while attributes
 508       (setq name (car attributes))
 509       (if (setq value (get-char-attribute char name))
 510           (cond ((eq name 'jisx0208-1978/4X)
 511                  (insert (format "(%-18s . #x%04X)%s"
 512                                  name value
 513                                  line-breaking)))
 514                 ((string-match "^->" (symbol-name name))
 515                  (insert
 516                   (format "(%-18s %s)%s"
 517                           name
 518                           (mapconcat (lambda (code)
 519                                        (cond ((symbolp code)
 520                                               (symbol-name code))
 521                                              ((integerp code)
 522                                               (format "#x%04X" code))
 523                                              (t
 524                                               (format "%s%S"
 525                                                       line-breaking code))))
 526                                      value " ")
 527                           line-breaking)))
 528                 ((memq name '(ideograph=
 529                               original-ideograph-of
 530                               vulgar-ideograph-of))
 531                  (insert (format "(%-18s%s " name line-breaking))
 532                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 533                        separator nil)
 534                  (while (consp value)
 535                    (setq cell (car value))
 536                    (if (and (consp cell)
 537                             (consp (car cell)))
 538                        (progn
 539                          (if separator
 540                              (insert lbs))
 541                          (char-db-insert-alist cell readable)
 542                          (setq separator lbs))
 543                      (if separator
 544                          (insert separator))
 545                      (insert (prin1-to-string cell))
 546                      (setq separator " "))
 547                    (setq value (cdr value)))
 548                  (insert ")")
 549                  (insert line-breaking))
 550                 ((consp value)
 551                  (insert (format "(%-18s " name))
 552                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 553                        separator nil)
 554                  (while (consp value)
 555                    (setq cell (car value))
 556                    (if (and (consp cell)
 557                             (consp (car cell))
 558                             (setq ret (condition-case nil
 559                                           (define-char cell)
 560                                         (error nil))))
 561                        (progn
 562                          (setq rest cell
 563                                al nil
 564                                cal nil)
 565                          (while rest
 566                            (setq key (car (car rest)))
 567                            (if (find-charset key)
 568                                (setq cal (cons key cal))
 569                              (setq al (cons key al)))
 570                            (setq rest (cdr rest)))
 571                          (if separator
 572                              (insert lbs))
 573                          (insert-char-attributes ret
 574                                                  readable
 575                                                  al cal)
 576                          (setq separator lbs))
 577                      (if separator
 578                          (insert separator))
 579                      (insert (prin1-to-string cell))
 580                      (setq separator " "))
 581                    (setq value (cdr value)))
 582                  (insert ")")
 583                  (insert line-breaking))
 584                 (t
 585                  (insert (format "(%-18s . %S)%s"
 586                                  name value
 587                                  line-breaking)))
 588                 ))
 589       (setq attributes (cdr attributes)))
 590     (while ccs-attributes
 591       (setq name (car ccs-attributes))
 592       (if (setq value (get-char-attribute char name))
 593           (insert
 594            (format
 595             (if has-long-ccs-name
 596                 (cond ((eq name 'ideograph-daikanwa)
 597                        "(%-26s . %05d)\t; %c%s"
 598                        )
 599                       ((eq name 'mojikyo)
 600                        "(%-26s . %06d)\t; %c%s"
 601                        )
 602                       (t
 603                        "(%-26s . #x%X)\t; %c%s"
 604                        ))
 605               (cond ((eq name 'ideograph-daikanwa)
 606                      "(%-18s . %05d)\t; %c%s"
 607                      )
 608                     ((eq name 'mojikyo)
 609                      "(%-18s . %06d)\t; %c%s"
 610                      )
 611                     (t
 612                      "(%-18s . #x%X)\t; %c%s"
 613                      )))
 614             name
 615             (if (= (charset-iso-graphic-plane name) 1)
 616                 (logior value
 617                         (cond ((= (charset-dimension name) 1)
 618                                #x80)
 619                               ((= (charset-dimension name) 2)
 620                                #x8080)
 621                               ((= (charset-dimension name) 3)
 622                                #x808080)
 623                               (t 0)))
 624               value)
 625             (decode-builtin-char name value)
 626             line-breaking)))
 627       (setq ccs-attributes (cdr ccs-attributes)))
 628     (insert ")")))
 629
 630 (defun insert-char-data (char &optional readable
 631                               attributes ccs-attributes)
 632   (save-restriction
 633     (narrow-to-region (point)(point))
 634     (insert "(define-char
 635   '")
 636     (insert-char-attributes char readable
 637                             attributes ccs-attributes)
 638     (insert ")\n")
 639     (goto-char (point-min))
 640     (while (re-search-forward "[ \t]+$" nil t)
 641       (replace-match ""))
 642     (goto-char (point-max))
 643     (tabify (point-min)(point-max))
 644     ))
 645
 646 ;;;###autoload
 647 (defun char-db-update-comment ()
 648   (interactive)
 649   (save-excursion
 650     (goto-char (point-min))
 651     (let (cdef table char)
 652       (while (re-search-forward "^[ \t]*\\(([^.()]+)\\)" nil t)
 653         (goto-char (match-beginning 1))
 654         (setq cdef (read (current-buffer)))
 655         (when (find-charset (car cdef))
 656           (goto-char (match-end 0))
 657           (setq char
 658                 (if (and
 659                      (not (eq (car cdef) 'ideograph-daikanwa))
 660                      (or (memq (car cdef) '(ascii latin-viscii-upper
 661                                                   latin-viscii-lower
 662                                                   arabic-iso8859-6
 663                                                   japanese-jisx0213-1
 664                                                   japanese-jisx0213-2))
 665                          (= (char-int (charset-iso-final-char (car cdef)))
 666                             0)))
 667                     (apply (function make-char) cdef)
 668                   (if (setq table (charset-mapping-table (car cdef)))
 669                       (set-charset-mapping-table (car cdef) nil))
 670                   (prog1
 671                       (apply (function make-char) cdef)
 672                     (if table
 673                         (set-charset-mapping-table (car cdef) table)))))
 674           (when (not (or (< (char-int char) 32)
 675                          (and (<= 128 (char-int char))
 676                               (< (char-int char) 160))))
 677             (delete-region (point) (point-at-eol))
 678             (insert (format "\t; %c" char)))
 679           )))))
 680
 681 (defun insert-char-data-with-variant (char &optional script printable
 682                                            no-ucs-variant)
 683   (insert-char-data char printable)
 684   (let ((variants (or (char-variants char)
 685                       (let ((ucs (get-char-attribute char '->ucs)))
 686                         (if ucs
 687                             (delete char (char-variants (int-char ucs)))))))
 688         variant vs)
 689     (while variants
 690       (setq variant (car variants))
 691       (if (or (null script)
 692               (null (setq vs (get-char-attribute variant 'script)))
 693               (memq script vs))
 694           (or (and no-ucs-variant (get-char-attribute variant 'ucs))
 695               (insert-char-data variant printable)))
 696       (setq variants (cdr variants))
 697       )))
 698
 699 (defun insert-char-range-data (min max &optional script)
 700   (let ((code min)
 701         char)
 702     (while (<= code max)
 703       (setq char (decode-char 'ucs code))
 704       (if (get-char-attribute char 'ucs)
 705           (insert-char-data-with-variant char script nil 'no-ucs-variant))
 706       (setq code (1+ code))
 707       )))
 708
 709 (defun write-char-range-data-to-file (min max file &optional script)
 710   (let ((coding-system-for-write 'utf-8))
 711     (with-temp-buffer
 712       (insert-char-range-data min max script)
 713       (write-region (point-min)(point-max) file))))
 714
 715 (defvar what-character-original-window-configuration)
 716
 717 ;;;###autoload
 718 (defun what-char-definition (char)
 719   (interactive (list (char-after)))
 720   (let ((buf (get-buffer-create "*Character Description*"))
 721         (the-buf (current-buffer))
 722         (win-conf (current-window-configuration)))
 723     (pop-to-buffer buf)
 724     (make-local-variable 'what-character-original-window-configuration)
 725     (setq what-character-original-window-configuration win-conf)
 726     (setq buffer-read-only nil)
 727     (erase-buffer)
 728     (condition-case err
 729         (progn
 730           (insert-char-data-with-variant char nil 'printable)
 731           ;; (char-db-update-comment)
 732           (set-buffer-modified-p nil)
 733           (view-mode the-buf (lambda (buf)
 734                                (set-window-configuration
 735                                 what-character-original-window-configuration)
 736                                ))
 737           (goto-char (point-min)))
 738       (error (progn
 739                (set-window-configuration
 740                 what-character-original-window-configuration)
 741                (signal (car err) (cdr err)))))))
 742
 743 (provide 'char-db-util)
 744
 745 ;;; char-db-util.el ends here