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                               wrong-ideograph-of
 534                               simplified-ideograph-of
 535                               ideographic-variants))
 536                  (insert (format "(%-18s%s " name line-breaking))
 537                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 538                        separator nil)
 539                  (while (consp value)
 540                    (setq cell (car value))
 541                    (if (and (consp cell)
 542                             (consp (car cell)))
 543                        (progn
 544                          (if separator
 545                              (insert lbs))
 546                          (char-db-insert-alist cell readable)
 547                          (setq separator lbs))
 548                      (if separator
 549                          (insert separator))
 550                      (insert (prin1-to-string cell))
 551                      (setq separator " "))
 552                    (setq value (cdr value)))
 553                  (insert ")")
 554                  (insert line-breaking))
 555                 ((consp value)
 556                  (insert (format "(%-18s " name))
 557                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 558                        separator nil)
 559                  (while (consp value)
 560                    (setq cell (car value))
 561                    (if (and (consp cell)
 562                             (consp (car cell))
 563                             (setq ret (condition-case nil
 564                                           (define-char cell)
 565                                         (error nil))))
 566                        (progn
 567                          (setq rest cell
 568                                al nil
 569                                cal nil)
 570                          (while rest
 571                            (setq key (car (car rest)))
 572                            (if (find-charset key)
 573                                (setq cal (cons key cal))
 574                              (setq al (cons key al)))
 575                            (setq rest (cdr rest)))
 576                          (if separator
 577                              (insert lbs))
 578                          (insert-char-attributes ret
 579                                                  readable
 580                                                  al cal)
 581                          (setq separator lbs))
 582                      (if separator
 583                          (insert separator))
 584                      (insert (prin1-to-string cell))
 585                      (setq separator " "))
 586                    (setq value (cdr value)))
 587                  (insert ")")
 588                  (insert line-breaking))
 589                 (t
 590                  (insert (format "(%-18s . %S)%s"
 591                                  name value
 592                                  line-breaking)))
 593                 ))
 594       (setq attributes (cdr attributes)))
 595     (while ccs-attributes
 596       (setq name (car ccs-attributes))
 597       (if (setq value (get-char-attribute char name))
 598           (insert
 599            (format
 600             (if has-long-ccs-name
 601                 (cond ((eq name 'ideograph-daikanwa)
 602                        "(%-26s . %05d)\t; %c%s"
 603                        )
 604                       ((eq name 'mojikyo)
 605                        "(%-26s . %06d)\t; %c%s"
 606                        )
 607                       (t
 608                        "(%-26s . #x%X)\t; %c%s"
 609                        ))
 610               (cond ((eq name 'ideograph-daikanwa)
 611                      "(%-18s . %05d)\t; %c%s"
 612                      )
 613                     ((eq name 'mojikyo)
 614                      "(%-18s . %06d)\t; %c%s"
 615                      )
 616                     (t
 617                      "(%-18s . #x%X)\t; %c%s"
 618                      )))
 619             name
 620             (if (= (charset-iso-graphic-plane name) 1)
 621                 (logior value
 622                         (cond ((= (charset-dimension name) 1)
 623                                #x80)
 624                               ((= (charset-dimension name) 2)
 625                                #x8080)
 626                               ((= (charset-dimension name) 3)
 627                                #x808080)
 628                               (t 0)))
 629               value)
 630             (decode-builtin-char name value)
 631             line-breaking)))
 632       (setq ccs-attributes (cdr ccs-attributes)))
 633     (insert ")")))
 634
 635 (defun insert-char-data (char &optional readable
 636                               attributes ccs-attributes)
 637   (save-restriction
 638     (narrow-to-region (point)(point))
 639     (insert "(define-char
 640   '")
 641     (insert-char-attributes char readable
 642                             attributes ccs-attributes)
 643     (insert ")\n")
 644     (goto-char (point-min))
 645     (while (re-search-forward "[ \t]+$" nil t)
 646       (replace-match ""))
 647     (goto-char (point-max))
 648     (tabify (point-min)(point-max))
 649     ))
 650
 651 ;;;###autoload
 652 (defun char-db-update-comment ()
 653   (interactive)
 654   (save-excursion
 655     (goto-char (point-min))
 656     (let (cdef table char)
 657       (while (re-search-forward "^[ \t]*\\(([^.()]+)\\)" nil t)
 658         (goto-char (match-beginning 1))
 659         (setq cdef (read (current-buffer)))
 660         (when (find-charset (car cdef))
 661           (goto-char (match-end 0))
 662           (setq char
 663                 (if (and
 664                      (not (eq (car cdef) 'ideograph-daikanwa))
 665                      (or (memq (car cdef) '(ascii latin-viscii-upper
 666                                                   latin-viscii-lower
 667                                                   arabic-iso8859-6
 668                                                   japanese-jisx0213-1
 669                                                   japanese-jisx0213-2))
 670                          (= (char-int (charset-iso-final-char (car cdef)))
 671                             0)))
 672                     (apply (function make-char) cdef)
 673                   (if (setq table (charset-mapping-table (car cdef)))
 674                       (set-charset-mapping-table (car cdef) nil))
 675                   (prog1
 676                       (apply (function make-char) cdef)
 677                     (if table
 678                         (set-charset-mapping-table (car cdef) table)))))
 679           (when (not (or (< (char-int char) 32)
 680                          (and (<= 128 (char-int char))
 681                               (< (char-int char) 160))))
 682             (delete-region (point) (point-at-eol))
 683             (insert (format "\t; %c" char)))
 684           )))))
 685
 686 (defun insert-char-data-with-variant (char &optional script printable
 687                                            no-ucs-variant)
 688   (insert-char-data char printable)
 689   (let ((variants (or (char-variants char)
 690                       (let ((ucs (get-char-attribute char '->ucs)))
 691                         (if ucs
 692                             (delete char (char-variants (int-char ucs)))))))
 693         variant vs)
 694     (while variants
 695       (setq variant (car variants))
 696       (if (or (null script)
 697               (null (setq vs (get-char-attribute variant 'script)))
 698               (memq script vs))
 699           (or (and no-ucs-variant (get-char-attribute variant 'ucs))
 700               (insert-char-data variant printable)))
 701       (setq variants (cdr variants))
 702       )))
 703
 704 (defun insert-char-range-data (min max &optional script)
 705   (let ((code min)
 706         char)
 707     (while (<= code max)
 708       (setq char (decode-char 'ucs code))
 709       (if (get-char-attribute char 'ucs)
 710           (insert-char-data-with-variant char script nil 'no-ucs-variant))
 711       (setq code (1+ code))
 712       )))
 713
 714 (defun write-char-range-data-to-file (min max file &optional script)
 715   (let ((coding-system-for-write 'utf-8))
 716     (with-temp-buffer
 717       (insert-char-range-data min max script)
 718       (write-region (point-min)(point-max) file))))
 719
 720 (defvar what-character-original-window-configuration)
 721
 722 ;;;###autoload
 723 (defun what-char-definition (char)
 724   (interactive (list (char-after)))
 725   (let ((buf (get-buffer-create "*Character Description*"))
 726         (the-buf (current-buffer))
 727         (win-conf (current-window-configuration)))
 728     (pop-to-buffer buf)
 729     (make-local-variable 'what-character-original-window-configuration)
 730     (setq what-character-original-window-configuration win-conf)
 731     (setq buffer-read-only nil)
 732     (erase-buffer)
 733     (condition-case err
 734         (progn
 735           (insert-char-data-with-variant char nil 'printable)
 736           ;; (char-db-update-comment)
 737           (set-buffer-modified-p nil)
 738           (view-mode the-buf (lambda (buf)
 739                                (set-window-configuration
 740                                 what-character-original-window-configuration)
 741                                ))
 742           (goto-char (point-min)))
 743       (error (progn
 744                (set-window-configuration
 745                 what-character-original-window-configuration)
 746                (signal (car err) (cdr err)))))))
 747
 748 (provide 'char-db-util)
 749
 750 ;;; char-db-util.el ends here