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