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

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