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