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                                            (or al 'none) 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         (sort (if attributes
 194                   (if (consp attributes)
 195                       (copy-sequence attributes))
 196                 (char-attribute-list))
 197               #'char-attribute-name<))
 198   (setq ccs-attributes
 199         (sort (if ccs-attributes
 200                   (copy-sequence ccs-attributes)
 201                 (charset-list))
 202               #'char-attribute-name<))
 203   (unless column
 204     (setq column (current-column)))
 205   (let (name value has-long-ccs-name rest
 206         radical strokes
 207         (line-breaking
 208          (concat "\n" (make-string (1+ column) ?\ )))
 209         lbs cell separator ret
 210         key al cal)
 211     (insert "(")
 212     (when (and (memq 'name attributes)
 213                (setq value (get-char-attribute char 'name)))
 214       (insert (format
 215                (if (> (length value) 47)
 216                    "(name . %S)%s"
 217                  "(name\t\t. %S)%s")
 218                value line-breaking))
 219       (setq attributes (delq 'name attributes))
 220       )
 221     (when (and (memq 'script attributes)
 222                (setq value (get-char-attribute char 'script)))
 223       (insert (format "(script\t\t%s)%s"
 224                       (mapconcat (function prin1-to-string)
 225                                  value " ")
 226                       line-breaking))
 227       (setq attributes (delq 'script attributes))
 228       )
 229     (when (and (memq '->ucs attributes)
 230                (setq value (get-char-attribute char '->ucs)))
 231       (insert (format "(->ucs\t\t. #x%04X)\t; %c%s"
 232                       value (decode-char 'ucs value)
 233                       line-breaking))
 234       (setq attributes (delq '->ucs attributes))
 235       )
 236     (when (and (memq 'general-category attributes)
 237                (setq value (get-char-attribute char 'general-category)))
 238       (insert (format
 239                "(general-category\t%s) ; %s%s"
 240                (mapconcat (lambda (cell)
 241                             (format "%S" cell))
 242                           value " ")
 243                (cond ((rassoc value unidata-normative-category-alist)
 244                       "Normative Category")
 245                      ((rassoc value unidata-informative-category-alist)
 246                       "Informative Category")
 247                      (t
 248                       "Unknown Category"))
 249                line-breaking))
 250       (setq attributes (delq 'general-category attributes))
 251       )
 252     (when (and (memq 'bidi-category attributes)
 253                (setq value (get-char-attribute char 'bidi-category)))
 254       (insert (format "(bidi-category\t. %S)%s"
 255                       value
 256                       line-breaking))
 257       (setq attributes (delq 'bidi-category attributes))
 258       )
 259     (unless (or (not (memq 'mirrored attributes))
 260                 (eq (setq value (get-char-attribute char 'mirrored 'empty))
 261                     'empty))
 262       (insert (format "(mirrored\t\t. %S)%s"
 263                       value
 264                       line-breaking))
 265       (setq attributes (delq 'mirrored attributes))
 266       )
 267     (cond
 268      ((and (memq 'decimal-digit-value attributes)
 269            (setq value (get-char-attribute char 'decimal-digit-value)))
 270       (insert (format "(decimal-digit-value . %S)%s"
 271                       value
 272                       line-breaking))
 273       (setq attributes (delq 'decimal-digit-value attributes))
 274       (when (and (memq 'digit-value attributes)
 275                  (setq value (get-char-attribute char 'digit-value)))
 276         (insert (format "(digit-value\t . %S)%s"
 277                         value
 278                         line-breaking))
 279         (setq attributes (delq 'digit-value attributes))
 280         )
 281       (when (and (memq 'numeric-value attributes)
 282                  (setq value (get-char-attribute char 'numeric-value)))
 283         (insert (format "(numeric-value\t . %S)%s"
 284                         value
 285                         line-breaking))
 286         (setq attributes (delq 'numeric-value attributes))
 287         )
 288       )
 289      (t
 290       (when (and (memq 'digit-value attributes)
 291                  (setq value (get-char-attribute char 'digit-value)))
 292         (insert (format "(digit-value\t. %S)%s"
 293                         value
 294                         line-breaking))
 295         (setq attributes (delq 'digit-value attributes))
 296         )
 297       (when (and (memq 'numeric-value attributes)
 298                  (setq value (get-char-attribute char 'numeric-value)))
 299         (insert (format "(numeric-value\t. %S)%s"
 300                         value
 301                         line-breaking))
 302         (setq attributes (delq 'numeric-value attributes))
 303         )))
 304     (when (and (memq 'iso-10646-comment attributes)
 305                (setq value (get-char-attribute char 'iso-10646-comment)))
 306       (insert (format "(iso-10646-comment\t. %S)%s"
 307                       value
 308                       line-breaking))
 309       (setq attributes (delq 'iso-10646-comment attributes))
 310       )
 311     (when (and (memq 'morohashi-daikanwa attributes)
 312                (setq value (get-char-attribute char 'morohashi-daikanwa)))
 313       (insert (format "(morohashi-daikanwa\t%s)%s"
 314                       (mapconcat (function prin1-to-string) value " ")
 315                       line-breaking))
 316       (setq attributes (delq 'morohashi-daikanwa attributes))
 317       )
 318     (setq radical nil
 319           strokes nil)
 320     (when (and (memq 'ideographic-radical attributes)
 321                (setq value (get-char-attribute char 'ideographic-radical)))
 322       (setq radical value)
 323       (insert (format "(ideographic-radical . %S)\t; %c%s"
 324                       radical
 325                       (aref ideographic-radicals radical)
 326                       line-breaking))
 327       (setq attributes (delq 'ideographic-radical attributes))
 328       )
 329     (when (and (memq 'ideographic-strokes attributes)
 330                (setq value (get-char-attribute char 'ideographic-strokes)))
 331       (setq strokes value)
 332       (insert (format "(ideographic-strokes . %S)%s"
 333                       strokes
 334                       line-breaking))
 335       (setq attributes (delq 'ideographic-strokes attributes))
 336       )
 337     (when (and (memq 'kangxi-radical attributes)
 338                (setq value (get-char-attribute char 'kangxi-radical)))
 339       (unless (eq value radical)
 340         (insert (format "(kangxi-radical\t . %S)\t; %c%s"
 341                         value
 342                         (aref ideographic-radicals value)
 343                         line-breaking))
 344         (or radical
 345             (setq radical value)))
 346       (setq attributes (delq 'kangxi-radical attributes))
 347       )
 348     (when (and (memq 'kangxi-strokes attributes)
 349                (setq value (get-char-attribute char 'kangxi-strokes)))
 350       (unless (eq value strokes)
 351         (insert (format "(kangxi-strokes\t . %S)%s"
 352                         value
 353                         line-breaking))
 354         (or strokes
 355             (setq strokes value)))
 356       (setq attributes (delq 'kangxi-strokes attributes))
 357       )
 358     (when (and (memq 'japanese-radical attributes)
 359                (setq value (get-char-attribute char 'japanese-radical)))
 360       (unless (eq value radical)
 361         (insert (format "(japanese-radical\t . %S)\t; %c%s"
 362                         value
 363                         (aref ideographic-radicals value)
 364                         line-breaking))
 365         (or radical
 366             (setq radical value)))
 367       (setq attributes (delq 'japanese-radical attributes))
 368       )
 369     (when (and (memq 'japanese-strokes attributes)
 370                (setq value (get-char-attribute char 'japanese-strokes)))
 371       (unless (eq value strokes)
 372         (insert (format "(japanese-strokes\t . %S)%s"
 373                         value
 374                         line-breaking))
 375         (or strokes
 376             (setq strokes value)))
 377       (setq attributes (delq 'japanese-strokes attributes))
 378       )
 379     (when (and (memq 'cns-radical attributes)
 380                (setq value (get-char-attribute char 'cns-radical)))
 381       (insert (format "(cns-radical\t . %S)\t; %c%s"
 382                       value
 383                       (aref ideographic-radicals value)
 384                       line-breaking))
 385       (setq attributes (delq 'cns-radical attributes))
 386       )
 387     (when (and (memq 'cns-strokes attributes)
 388                (setq value (get-char-attribute char 'cns-strokes)))
 389       (unless (eq value strokes)
 390         (insert (format "(cns-strokes\t . %S)%s"
 391                         value
 392                         line-breaking))
 393         (or strokes
 394             (setq strokes value)))
 395       (setq attributes (delq 'cns-strokes attributes))
 396       )
 397     (when (and (memq 'shinjigen-1-radical attributes)
 398                (setq value (get-char-attribute char 'shinjigen-1-radical)))
 399       (unless (eq value radical)
 400         (insert (format "(shinjigen-1-radical . %S)\t; %c%s"
 401                         value
 402                         (aref ideographic-radicals value)
 403                         line-breaking))
 404         (or radical
 405             (setq radical value)))
 406       (setq attributes (delq 'shinjigen-1-radical attributes))
 407       )
 408     (when (and (memq 'total-strokes attributes)
 409                (setq value (get-char-attribute char 'total-strokes)))
 410       (insert (format "(total-strokes       . %S)%s"
 411                       value
 412                       line-breaking))
 413       (setq attributes (delq 'total-strokes attributes))
 414       )
 415     (when (and (memq '->ideograph attributes)
 416                (setq value (get-char-attribute char '->ideograph)))
 417       (insert (format "(->ideograph\t%s)%s"
 418                       (mapconcat (lambda (code)
 419                                    (cond ((symbolp code)
 420                                           (symbol-name code))
 421                                          ((integerp code)
 422                                           (format "#x%04X" code))
 423                                          (t
 424                                           (format "%s%S" line-breaking code))))
 425                                  value " ")
 426                       line-breaking))
 427       (setq attributes (delq '->ideograph attributes))
 428       )
 429     (when (and (memq '->decomposition attributes)
 430                (setq value (get-char-attribute char '->decomposition)))
 431       (insert (format "(->decomposition\t%s)%s"
 432                       (mapconcat (lambda (code)
 433                                    (cond ((symbolp code)
 434                                           (symbol-name code))
 435                                          ((characterp code)
 436                                           (if readable
 437                                               (format "%S" code)
 438                                             (format "#x%04X"
 439                                                     (char-int code))
 440                                             ))
 441                                          ((integerp code)
 442                                           (format "#x%04X" code))
 443                                          (t
 444                                           (format "%s%S" line-breaking code))))
 445                                  value " ")
 446                       line-breaking))
 447       (setq attributes (delq '->decomposition attributes))
 448       )
 449     (when (and (memq '->uppercase attributes)
 450                (setq value (get-char-attribute char '->uppercase)))
 451       (insert (format "(->uppercase\t%s)%s"
 452                       (mapconcat (lambda (code)
 453                                    (cond ((symbolp code)
 454                                           (symbol-name code))
 455                                          ((integerp code)
 456                                           (format "#x%04X" code))
 457                                          (t
 458                                           (format "%s%S" line-breaking code))))
 459                                  value " ")
 460                       line-breaking))
 461       (setq attributes (delq '->uppercase attributes))
 462       )
 463     (when (and (memq '->lowercase attributes)
 464                (setq value (get-char-attribute char '->lowercase)))
 465       (insert (format "(->lowercase\t%s)%s"
 466                       (mapconcat (lambda (code)
 467                                    (cond ((symbolp code)
 468                                           (symbol-name code))
 469                                          ((integerp code)
 470                                           (format "#x%04X" code))
 471                                          (t
 472                                           (format "%s%S" line-breaking code))))
 473                                  value " ")
 474                       line-breaking))
 475       (setq attributes (delq '->lowercase attributes))
 476       )
 477     (when (and (memq '->titlecase attributes)
 478                (setq value (get-char-attribute char '->titlecase)))
 479       (insert (format "(->titlecase\t%s)%s"
 480                       (mapconcat (lambda (code)
 481                                    (cond ((symbolp code)
 482                                           (symbol-name code))
 483                                          ((integerp code)
 484                                           (format "#x%04X" code))
 485                                          (t
 486                                           (format "%s%S" line-breaking code))))
 487                                  value " ")
 488                       line-breaking))
 489       (setq attributes (delq '->titlecase attributes))
 490       )
 491     (when (and (memq '->mojikyo attributes)
 492                (setq value (get-char-attribute char '->mojikyo)))
 493       (insert (format "(->mojikyo\t\t. %06d)\t; %c%s"
 494                       value (decode-char 'mojikyo value)
 495                       line-breaking))
 496       (setq attributes (delq '->mojikyo attributes))
 497       )
 498     (setq rest ccs-attributes)
 499     (while (and rest
 500                 (progn
 501                   (setq value (get-char-attribute char (car rest)))
 502                   (if value
 503                       (if (>= (length (symbol-name (car rest))) 19)
 504                           (progn
 505                             (setq has-long-ccs-name t)
 506                             nil)
 507                         t)
 508                     t)))
 509       (setq rest (cdr rest)))
 510     (while attributes
 511       (setq name (car attributes))
 512       (if (setq value (get-char-attribute char name))
 513           (cond ((eq name 'jisx0208-1978/4X)
 514                  (insert (format "(%-18s . #x%04X)%s"
 515                                  name value
 516                                  line-breaking)))
 517                 ((string-match "^->" (symbol-name name))
 518                  (insert
 519                   (format "(%-18s %s)%s"
 520                           name
 521                           (mapconcat (lambda (code)
 522                                        (cond ((symbolp code)
 523                                               (symbol-name code))
 524                                              ((integerp code)
 525                                               (format "#x%04X" code))
 526                                              (t
 527                                               (format "%s%S"
 528                                                       line-breaking code))))
 529                                      value " ")
 530                           line-breaking)))
 531                 ((memq name '(ideograph=
 532                               original-ideograph-of
 533                               ancient-ideograph-of
 534                               vulgar-ideograph-of
 535                               wrong-ideograph-of
 536                               simplified-ideograph-of
 537                               ideographic-variants
 538                               ideographic-different-form-of))
 539                  (insert (format "(%-18s%s " name line-breaking))
 540                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 541                        separator nil)
 542                  (while (consp value)
 543                    (setq cell (car value))
 544                    (if (and (consp cell)
 545                             (consp (car cell)))
 546                        (progn
 547                          (if separator
 548                              (insert lbs))
 549                          (char-db-insert-alist cell readable)
 550                          (setq separator lbs))
 551                      (if separator
 552                          (insert separator))
 553                      (insert (prin1-to-string cell))
 554                      (setq separator " "))
 555                    (setq value (cdr value)))
 556                  (insert ")")
 557                  (insert line-breaking))
 558                 ((consp value)
 559                  (insert (format "(%-18s " name))
 560                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 561                        separator nil)
 562                  (while (consp value)
 563                    (setq cell (car value))
 564                    (if (and (consp cell)
 565                             (consp (car cell))
 566                             (setq ret (condition-case nil
 567                                           (define-char cell)
 568                                         (error nil))))
 569                        (progn
 570                          (setq rest cell
 571                                al nil
 572                                cal nil)
 573                          (while rest
 574                            (setq key (car (car rest)))
 575                            (if (find-charset key)
 576                                (setq cal (cons key cal))
 577                              (setq al (cons key al)))
 578                            (setq rest (cdr rest)))
 579                          (if separator
 580                              (insert lbs))
 581                          (insert-char-attributes ret
 582                                                  readable
 583                                                  al cal)
 584                          (setq separator lbs))
 585                      (if separator
 586                          (insert separator))
 587                      (insert (prin1-to-string cell))
 588                      (setq separator " "))
 589                    (setq value (cdr value)))
 590                  (insert ")")
 591                  (insert line-breaking))
 592                 (t
 593                  (insert (format "(%-18s . %S)%s"
 594                                  name value
 595                                  line-breaking)))
 596                 ))
 597       (setq attributes (cdr attributes)))
 598     (while ccs-attributes
 599       (setq name (car ccs-attributes))
 600       (if (setq value (get-char-attribute char name))
 601           (insert
 602            (format
 603             (if has-long-ccs-name
 604                 (cond ((eq name 'ideograph-daikanwa)
 605                        "(%-26s . %05d)\t; %c%s"
 606                        )
 607                       ((eq name 'mojikyo)
 608                        "(%-26s . %06d)\t; %c%s"
 609                        )
 610                       (t
 611                        "(%-26s . #x%X)\t; %c%s"
 612                        ))
 613               (cond ((eq name 'ideograph-daikanwa)
 614                      "(%-18s . %05d)\t; %c%s"
 615                      )
 616                     ((eq name 'mojikyo)
 617                      "(%-18s . %06d)\t; %c%s"
 618                      )
 619                     (t
 620                      "(%-18s . #x%X)\t; %c%s"
 621                      )))
 622             name
 623             (if (= (charset-iso-graphic-plane name) 1)
 624                 (logior value
 625                         (cond ((= (charset-dimension name) 1)
 626                                #x80)
 627                               ((= (charset-dimension name) 2)
 628                                #x8080)
 629                               ((= (charset-dimension name) 3)
 630                                #x808080)
 631                               (t 0)))
 632               value)
 633             (decode-builtin-char name value)
 634             line-breaking)))
 635       (setq ccs-attributes (cdr ccs-attributes)))
 636     (insert ")")))
 637
 638 (defun insert-char-data (char &optional readable
 639                               attributes ccs-attributes)
 640   (save-restriction
 641     (narrow-to-region (point)(point))
 642     (insert "(define-char
 643   '")
 644     (insert-char-attributes char readable
 645                             attributes ccs-attributes)
 646     (insert ")\n")
 647     (goto-char (point-min))
 648     (while (re-search-forward "[ \t]+$" nil t)
 649       (replace-match ""))
 650     (goto-char (point-max))
 651     (tabify (point-min)(point-max))
 652     ))
 653
 654 ;;;###autoload
 655 (defun char-db-update-comment ()
 656   (interactive)
 657   (save-excursion
 658     (goto-char (point-min))
 659     (let (cdef table char)
 660       (while (re-search-forward "^[ \t]*\\(([^.()]+)\\)" nil t)
 661         (goto-char (match-beginning 1))
 662         (setq cdef (read (current-buffer)))
 663         (when (find-charset (car cdef))
 664           (goto-char (match-end 0))
 665           (setq char
 666                 (if (and
 667                      (not (eq (car cdef) 'ideograph-daikanwa))
 668                      (or (memq (car cdef) '(ascii latin-viscii-upper
 669                                                   latin-viscii-lower
 670                                                   arabic-iso8859-6
 671                                                   japanese-jisx0213-1
 672                                                   japanese-jisx0213-2))
 673                          (= (char-int (charset-iso-final-char (car cdef)))
 674                             0)))
 675                     (apply (function make-char) cdef)
 676                   (if (setq table (charset-mapping-table (car cdef)))
 677                       (set-charset-mapping-table (car cdef) nil))
 678                   (prog1
 679                       (apply (function make-char) cdef)
 680                     (if table
 681                         (set-charset-mapping-table (car cdef) table)))))
 682           (when (not (or (< (char-int char) 32)
 683                          (and (<= 128 (char-int char))
 684                               (< (char-int char) 160))))
 685             (delete-region (point) (point-at-eol))
 686             (insert (format "\t; %c" char)))
 687           )))))
 688
 689 (defun insert-char-data-with-variant (char &optional script printable
 690                                            no-ucs-variant)
 691   (insert-char-data char printable)
 692   (let ((variants (or (char-variants char)
 693                       (let ((ucs (get-char-attribute char '->ucs)))
 694                         (if ucs
 695                             (delete char (char-variants (int-char ucs)))))))
 696         variant vs)
 697     (while variants
 698       (setq variant (car variants))
 699       (if (or (null script)
 700               (null (setq vs (get-char-attribute variant 'script)))
 701               (memq script vs))
 702           (or (and no-ucs-variant (get-char-attribute variant 'ucs))
 703               (insert-char-data variant printable)))
 704       (setq variants (cdr variants))
 705       )))
 706
 707 (defun insert-char-range-data (min max &optional script)
 708   (let ((code min)
 709         char)
 710     (while (<= code max)
 711       (setq char (decode-char 'ucs code))
 712       (if (get-char-attribute char 'ucs)
 713           (insert-char-data-with-variant char script nil 'no-ucs-variant))
 714       (setq code (1+ code))
 715       )))
 716
 717 (defun write-char-range-data-to-file (min max file &optional script)
 718   (let ((coding-system-for-write 'utf-8))
 719     (with-temp-buffer
 720       (insert-char-range-data min max script)
 721       (write-region (point-min)(point-max) file))))
 722
 723 (defvar what-character-original-window-configuration)
 724
 725 ;;;###autoload
 726 (defun what-char-definition (char)
 727   (interactive (list (char-after)))
 728   (let ((buf (get-buffer-create "*Character Description*"))
 729         (the-buf (current-buffer))
 730         (win-conf (current-window-configuration)))
 731     (pop-to-buffer buf)
 732     (make-local-variable 'what-character-original-window-configuration)
 733     (setq what-character-original-window-configuration win-conf)
 734     (setq buffer-read-only nil)
 735     (erase-buffer)
 736     (condition-case err
 737         (progn
 738           (insert-char-data-with-variant char nil 'printable)
 739           ;; (char-db-update-comment)
 740           (set-buffer-modified-p nil)
 741           (view-mode the-buf (lambda (buf)
 742                                (set-window-configuration
 743                                 what-character-original-window-configuration)
 744                                ))
 745           (goto-char (point-min)))
 746       (error (progn
 747                (set-window-configuration
 748                 what-character-original-window-configuration)
 749                (signal (car err) (cdr err)))))))
 750
 751 (provide 'char-db-util)
 752
 753 ;;; char-db-util.el ends here