Mercurial > hg > xemacs-beta

comparison lisp/mule/mule-debug.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents
children a145efe76779
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; mule-diag.el --- debugging functions for Mule.
2
3 ;; Copyright (C) 1992 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Sun Microsystems.
5
6 ;; This file is part of XEmacs.
7
8 ;; XEmacs is free software; you can redistribute it and/or modify it
9 ;; under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation; either version 2, or (at your option)
11 ;; any later version.
12
13 ;; XEmacs is distributed in the hope that it will be useful, but
14 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 ;; General Public License for more details.
17
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with XEmacs; see the file COPYING. If not, write to the
20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 ;; Boston, MA 02111-1307, USA.
22
23 ;;; 93.7.28 created for Mule Ver.0.9.8 by K.Handa <handa@etl.go.jp>
24
25 ;;; General utility function
26
27 (defun mule-debug-princ-list (&rest args)
28 (while (cdr args)
29 (if (car args)
30 (progn (princ (car args)) (princ " ")))
31 (setq args (cdr args)))
32 (princ (car args))
33 (princ "\n"))
34
35 ;;; character sets
36
37 ;;;###autoload
38 (defun list-charsets ()
39 "Display a list of existing character sets."
40 (interactive)
41 (with-output-to-temp-buffer "*Charset List*"
42 (princ "## LIST OF CHARACTER SETS\n")
43 (princ
44 "NAME REGISTRY BYTES CHARS FINAL GRAPHIC DIR\n")
45 (princ
46 "--------------------------------------------------------------------")
47 (mapcar
48 (lambda (name)
49 (let ((charset (get-charset name)))
50 (princ (format
51 "%20s %15s %5d %5d %5d %7d %s\n"
52 name
53 (charset-registry charset)
54 (charset-dimension charset)
55 (charset-chars charset)
56 (charset-final charset)
57 (charset-graphic charset)
58 (charset-direction charset)))
59 (princ " ")
60 (princ "%s\n" (charset-doc-string charset))))
61 (charset-list))
62
63 (princ "## CCL PROGRAM TO CONVERT INTERNAL TO EXTERNAL CODE\n")
64 (princ "NAME CCL-PROGRAMS\n")
65 (mapcar
66 (lambda (name)
67 (let ((ccl (charset-ccl-program name)))
68 (if ccl
69 (let ((i 0) (len (length ccl)))
70 (princ (format "%20s " name))
71 (while (< i len)
72 (princ (format " %x" (aref ccl i)))
73 (setq i (1+ i)))
74 (princ "\n")))))
75 (charset-list))
76 ))
77
78 (defun describe-designation (flags graphic)
79 (let ((lc (aref flags graphic))
80 lc1)
81 (if (integerp lc) (setq lc1 (if (> lc 0) lc (- lc))))
82 (princ (format " G%d -- %s"
83 graphic
84 (or (and lc1 (char-description lc1))
85 (and (eq lc t) "never used")
86 "none")))
87 (princ (if (and lc1 (< lc 0))
88 " (explicit designation required)\n"
89 "\n"))))
90 ;; end of patch
91
92 ;;;###autoload
93 (defun describe-coding-system (cs)
94 "Display documentation of the coding-system CS."
95 (interactive "zCoding-system: ")
96 (get-coding-system cs);; correctness check
97 (with-output-to-temp-buffer "*Help*"
98 (princ "Coding-system ")
99 (princ cs)
100 (princ " [")
101 (princ (coding-system-mnemonic cs))
102 (princ "]: \n")
103 (if (not cs) nil
104 (princ " ")
105 (princ (coding-system-doc-string cs))
106 (princ "\nType: ")
107 (let ((type (coding-system-type cs)))
108 (princ type)
109 (cond ((eq type 'iso2022)
110 (princ "ISO-2022]\n")
111 (princ "Initial designations:\n")
112 (describe-designation coding-system 0)
113 (describe-designation coding-system 1)
114 (describe-designation coding-system 2)
115 (describe-designation coding-system 3)
116 (princ "Other Form: \n")
117 (princ (if (aref flags 4) "ShortForm" "LongForm"))
118 (if (aref flags 5) (princ ", ASCII@EOL"))
119 (if (aref flags 6) (princ ", ASCII@CNTL"))
120 (princ (if (aref flags 7) ", 7bit" ", 8bit"))
121 (if (aref flags 8) (princ ", UseLockingShift"))
122 (if (aref flags 9) (princ ", UseRoman"))
123 (if (aref flags 10) (princ ", UseOldJIS"))
124 (if (aref flags 11) (princ ", No ISO6429"))
125 (princ ".\n"))
126 ((eq type 'big5)
127 (princ (if flags "Big-ETen\n" "Big-HKU\n")))
128 ))
129 (princ "\nEOL-Type: ")
130 (let ((eol-type (coding-system-eol-type cs)))
131 (cond ((null eol-type)
132 (princ "null (= LF)\n"))
133 ((vectorp eol-type)
134 (princ "Automatic selection from ")
135 (princ eol-type)
136 (princ "\n"))
137 ((eq eol-type 1) (princ "LF\n"))
138 ((eq eol-type 2) (princ "CRLF\n"))
139 ((eq eol-type 3) (princ "CR\n"))
140 (t (princ "invalid\n"))))
141 )))
142
143 ;;;###autoload
144 (defun list-coding-system-briefly ()
145 "Display coding-systems currently used with a brief format in mini-buffer."
146 (interactive)
147 (let ((cs (and (fboundp 'process-coding-system) (process-coding-system)))
148 eol-type)
149 (message
150 "current: [FKDPp=%c%c%c%c%c%c%c%c] default: [FPp=%c%c%c%c%c%c]"
151 (coding-system-mnemonic file-coding-system)
152 (coding-system-eol-mnemonic file-coding-system)
153 (coding-system-mnemonic keyboard-coding-system)
154 (coding-system-mnemonic terminal-coding-system)
155 (coding-system-mnemonic (car cs))
156 (coding-system-eol-mnemonic (car cs))
157 (coding-system-mnemonic (cdr cs))
158 (coding-system-eol-mnemonic (cdr cs))
159 (coding-system-mnemonic (default-value 'file-coding-system))
160 (coding-system-eol-mnemonic (default-value 'file-coding-system))
161 (coding-system-mnemonic (car default-process-coding-system))
162 (coding-system-eol-mnemonic (car default-process-coding-system))
163 (coding-system-mnemonic (cdr default-process-coding-system))
164 (coding-system-eol-mnemonic (cdr default-process-coding-system))
165 )))
166
167 (defun princ-coding-system (code)
168 (princ ": ")
169 (princ code)
170 (princ " [")
171 (princ (char-to-string (coding-system-mnemonic code)))
172 (princ (char-to-string (coding-system-eol-mnemonic code)))
173 (princ "]\n"))
174
175 (defun todigit (flags idx &optional default-value)
176 (if (aref flags idx)
177 (if (numberp (aref flags idx)) (aref flags idx) 1)
178 (or default-value 0)))
179
180 (defun print-coding-system-description (code)
181 (let ((type (get-code-type code))
182 (eol (or (get-code-eol code) 1))
183 (flags (get-code-flags code))
184 line)
185 (setq type
186 (cond ((null type) 0)
187 ((eq type t) 2)
188 ((eq type 0) 1)
189 ((eq type 1) 3)
190 ((eq type 2) 4)
191 ((eq type 3) 5)
192 ((eq type 4) 6)
193 (t nil)))
194 (if (or (null type)
195 (get code 'post-read-conversion)
196 (get (get-base-code code) 'post-read-conversion)
197 (get code 'pre-write-conversion)
198 (get (get-base-code code) 'pre-write-conversion)
199 (eq code '*noconv*))
200 nil
201 (princ
202 (format "%s:%d:%c:"
203 code type (coding-system-mnemonic code)))
204 (princ (format "%d" (if (numberp eol) eol 0)))
205 (cond ((= type 4)
206 (princ
207 (format
208 ":%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d"
209 (todigit flags 0 -1)
210 (todigit flags 1 -1)
211 (todigit flags 2 -1)
212 (todigit flags 3 -1)
213 (todigit flags 4)
214 (todigit flags 5)
215 (todigit flags 6)
216 (todigit flags 7)
217 (todigit flags 8)
218 (todigit flags 9)
219 (todigit flags 10)
220 (todigit flags 11))))
221 ((= type 5)
222 (princ ":0"))
223 ((= type 6)
224 (if (and (vectorp (car flags)) (vectorp (cdr flags)))
225 (let (i len)
226 (princ ":")
227 (setq i 0 len (length (car flags)))
228 (while (< i len)
229 (princ (format " %x" (aref (car flags) i)))
230 (setq i (1+ i)))
231 (princ ",")
232 (setq i 0 len (length (cdr flags)))
233 (while (< i len)
234 (princ (format " %x" (aref (cdr flags) i)))
235 (setq i (1+ i))))))
236 (t (princ ":0")))
237 (princ ":")
238 (princ (get-code-document code))
239 (princ "\n"))
240 ))
241
242 ;;;###autoload
243 (defun list-coding-system (&optional all)
244 "Describe coding-systems currently used with a detailed format.
245 If optional arg ALL is non-nil, all coding-systems are listed in
246 machine readable simple format."
247 (interactive "P")
248 (with-output-to-temp-buffer "*Help*"
249 (if (null all)
250 (let ((cs (and (fboundp 'process-coding-system)
251 (process-coding-system))))
252 (princ "Current:\n file-coding-system")
253 (princ-coding-system file-coding-system)
254 (princ " keyboard-coding-system")
255 (princ-coding-system keyboard-coding-system)
256 (princ " terminal-coding-system")
257 (princ-coding-system terminal-coding-system)
258 (when cs
259 (princ " process-coding-system (input)")
260 (princ-coding-system (car cs))
261 (princ " process-coding-system (output)")
262 (princ-coding-system (cdr cs)))
263 (princ "Default:\n file-coding-system")
264 (princ-coding-system (default-value 'file-coding-system))
265 (princ " process-coding-system (input)")
266 (princ-coding-system (car default-process-coding-system))
267 (princ " process-coding-system (output)")
268 (princ-coding-system (cdr default-process-coding-system))
269 (princ "Others:\n file-coding-system-for-read")
270 (princ-coding-system file-coding-system-for-read)
271 (princ "Coding categories by priority:\n")
272 (princ (coding-priority-list)))
273 (princ "########################\n")
274 (princ "## LIST OF CODING SYSTEM\n")
275 (princ "## NAME(str):TYPE(int):MNEMONIC(char):EOL(int):FLAGS:DOC(str)\n")
276 (princ "## TYPE = 0(no conversion),1(auto conversion),\n")
277 (princ "## 2(Mule internal),3(SJIS),4(ISO2022),5(BIG5),6(CCL)\n")
278 (princ "## EOL = 0(AUTO), 1(LF), 2(CRLF), 3(CR)\n")
279 (princ "## FLAGS =\n")
280 (princ "## if TYPE = 4 then\n")
281 (princ "## G0,G1,G2,G3,SHORT,ASCII-EOL,ASCII-CNTL,SEVEN,\n")
282 (princ "## LOCK-SHIFT,USE-ROMAN,USE-OLDJIS\n")
283 (princ "## else if TYPE = 6 then\n")
284 (princ "## CCL_PROGRAM_FOR_READ,CCL_PROGRAM_FOR_WRITE\n")
285 (princ "## else\n")
286 (princ "## 0\n")
287 (princ "##\n")
288 (let ((codings nil))
289 (mapatoms
290 (function
291 (lambda (arg)
292 (if (eq arg '*noconv*)
293 nil
294 (if (and (or (vectorp (get arg 'coding-system))
295 (vectorp (get arg 'eol-type)))
296 (null (get arg 'pre-write-conversion))
297 (null (get arg 'post-read-conversion)))
298 (setq codings (cons arg codings)))))))
299 (while codings
300 (print-coding-system-description (car codings))
301 (setq codings (cdr codings))))
302 (princ "############################\n")
303 (princ "## LIST OF CODING CATEGORIES (ordered by priority)\n")
304 (princ "## CATEGORY(str):CODING-SYSTEM(str)\n")
305 (princ "##\n")
306 (princ (coding-priority-list))
307 )))
308
309 ;;; FONT
310 (defun describe-font-internal (fontinfo &optional verbose)
311 (let ((cs (character-set (aref fontinfo 3))))
312 (mule-debug-princ-list (format "Font #%02d for" (aref fontinfo 0))
313 (nth 6 cs) (nth 7 cs) "--"
314 (cond ((= (aref fontinfo 4) 0) "NOT YET OPENED")
315 ((= (aref fontinfo 4) 1) "OPENED")
316 (t "NOT FOUND")))
317 (mule-debug-princ-list " request:" (aref fontinfo 1))
318 (if (= (aref fontinfo 4) 1)
319 (mule-debug-princ-list " opened:" (aref fontinfo 2)))
320 (if (and verbose (= (aref fontinfo 4) 1))
321 (progn
322 (mule-debug-princ-list " size:" (format "%d" (aref fontinfo 5)))
323 (mule-debug-princ-list " encoding:" (if (= (aref fontinfo 6) 0) "low" "high"))
324 (mule-debug-princ-list " yoffset:" (format "%d" (aref fontinfo 7)))
325 (mule-debug-princ-list " rel-cmp:" (format "%d" (aref fontinfo 8)))))
326 ))
327
328 ;;;###autoload
329 (defun describe-font (fontname)
330 "Display information about fonts which partially match FONTNAME."
331 (interactive "sFontname: ")
332 (setq fontname (regexp-quote fontname))
333 (with-output-to-temp-buffer "*Help*"
334 (let ((fontlist (font-list)) fontinfo)
335 (while fontlist
336 (setq fontinfo (car fontlist))
337 (if (or (string-match fontname (aref fontinfo 1))
338 (and (aref fontinfo 2)
339 (string-match fontname (aref fontinfo 2))))
340 (describe-font-internal fontinfo 'verbose))
341 (setq fontlist (cdr fontlist))))))
342
343 ;;;###autoload
344 (defun list-font ()
345 "Display a list of fonts."
346 (interactive)
347 (with-output-to-temp-buffer "*Help*"
348 (let ((fontlist (font-list)))
349 (while fontlist
350 (describe-font-internal (car fontlist))
351 (setq fontlist (cdr fontlist))))))
352
353 ;;; FONTSET
354 (defun describe-fontset-internal (fontset-info)
355 (mule-debug-princ-list "### Fontset-name:" (car fontset-info) "###")
356 (let ((i 0) font)
357 (while (< i 128)
358 (if (>= (setq font (aref (cdr fontset-info) i)) 0)
359 (describe-font-internal (get-font-info font)))
360 (setq i (1+ i)))))
361
362 ;;;###autoload
363 (defun describe-fontset (fontset)
364 "Display information about FONTSET."
365 (interactive
366 (let ((fontset-list (mapcar '(lambda (x) (list x)) (fontset-list))))
367 (list (completing-read "Fontset: " fontset-list nil 'match))))
368 (let ((fontset-info (get-fontset-info fontset)))
369 (if fontset-info
370 (with-output-to-temp-buffer "*Help*"
371 (describe-fontset-internal fontset-info))
372 (error "No such fontset: %s" fontset))))
373
374 ;;;###autoload
375 (defun list-fontset ()
376 "Display a list of fontsets."
377 (interactive)
378 (with-output-to-temp-buffer "*Help*"
379 (let ((fontsetlist (fontset-list 'all)))
380 (while fontsetlist
381 (describe-fontset-internal (car fontsetlist))
382 (setq fontsetlist (cdr fontsetlist))))))
383
384 ;;; DIAGNOSIS
385
386 (defun insert-list (args)
387 (while (cdr args)
388 (insert (or (car args) "nil") " ")
389 (setq args (cdr args)))
390 (if args (insert (or (car args) "nil")))
391 (insert "\n"))
392
393 (defun insert-section (sec title)
394 (insert "########################################\n"
395 "# Section " (format "%d" sec) ". " title "\n"
396 "########################################\n\n"))
397
398 ;;;###autoload
399 (defun mule-diag ()
400 "Show diagnosis of the current running Mule."
401 (interactive)
402 (let ((buf (get-buffer-create "*Diagnosis*")))
403 (save-excursion
404 (set-buffer buf)
405 (erase-buffer)
406 (insert "\t##############################\n"
407 "\t### DIAGNOSIS OF YOUR MULE ###\n"
408 "\t##############################\n\n"
409 "CONTENTS: Section 0. General information\n"
410 " Section 1. Display\n"
411 " Section 2. Input methods\n"
412 " Section 3. Coding-systems\n"
413 " Section 4. Character sets\n")
414 (if window-system
415 (insert " Section 5. Fontset list\n"))
416 (insert "\n")
417
418 (insert-section 0 "General information")
419 (insert "Mule's version: " mule-version " of " mule-version-date "\n")
420 (if window-system
421 (insert "Window-system: "
422 (symbol-name window-system)
423 (format "%s" window-system-version))
424 (insert "Terminal: " (getenv "TERM")))
425 (insert "\n\n")
426
427 (insert-section 1 "Display")
428 (if (eq window-system 'x)
429 (let* ((alist (nth 1 (assq (selected-frame)
430 (current-frame-configuration))))
431 (fontset (cdr (assq 'font alist))))
432 (insert-list (cons "Defined fontsets:" (fontset-list)))
433 (insert "Current frame's fontset: " fontset "\n"
434 "See Section 5 for more detail.\n\n"))
435 (insert "Coding system for output to terminal: "
436 (symbol-name terminal-coding-system)
437 "\n\n"))
438 (insert-section 2 "Input methods")
439 (if (featurep 'egg)
440 (let (temp)
441 (insert "EGG (Version " egg-version ")\n")
442 (insert " jserver host list: ")
443 (insert-list (if (boundp 'jserver-list) jserver-list
444 (if (setq temp (getenv "JSERVER"))
445 (list temp))))
446 (insert " cserver host list: ")
447 (insert-list (if (boundp 'cserver-list) cserver-list
448 (if (setq temp (getenv "CSERVER"))
449 (list temp))))
450 (insert " loaded ITS mode:\n\t")
451 (insert-list (mapcar 'car its:*mode-alist*))
452 (insert " current server:" (symbol-name wnn-server-type) "\n"
453 " current ITS mode:"
454 (let ((mode its:*mode-alist*))
455 (while (not (eq (cdr (car mode)) its:*current-map*))
456 (setq mode (cdr mode)))
457 (car (car mode))))
458 (insert "\n")))
459 (insert "QUAIL (Version " quail-version ")\n")
460 (insert " Quail packages: (not-yet-loaded) [current]\n\t")
461 (let ((l quail-package-alist)
462 (current (or (car quail-current-package) "")))
463 (while l
464 (cond ((string= current (car (car l)))
465 (insert "[" (car (car l)) "]"))
466 ((nth 2 (car l))
467 (insert (car (car l))))
468 (t
469 (insert "(" (car (car l)) ")")))
470 (if (setq l (cdr l)) (insert " ") (insert "\n"))))
471 (if (featurep 'canna)
472 (insert "CANNA (Version " canna-rcs-version ")\n"
473 " server:" (or canna-server "Not specified") "\n"))
474 (if (featurep 'sj3-egg)
475 (insert "SJ3 (Version" sj3-egg-version ")\n"
476 " server:" (get-sj3-host-name) "\n"))
477 (insert "\n")
478
479 (insert-section 3 "Coding systems")
480 (save-excursion (list-coding-systems))
481 (insert-buffer "*Help*")
482 (goto-char (point-max))
483 (insert "\n")
484
485 (insert-section 4 "Character sets")
486 (save-excursion (list-charsets))
487 (insert-buffer "*Help*")
488 (goto-char (point-max))
489 (insert "\n")
490
491 (if window-system
492 (progn
493 (insert-section 5 "Fontset list")
494 (save-excursion (list-fontset))
495 (insert-buffer "*Help*")))
496
497 (set-buffer-modified-p nil)
498 )
499 (let ((win (display-buffer buf)))
500 (set-window-point win 1)
501 (set-window-start win 1))
502 ))
503
504 ;;; DUMP DATA FILE
505
506 ;;;###autoload
507 (defun dump-charsets ()
508 (list-charsets)
509 (set-buffer (get-buffer "*Help*"))
510 (let (make-backup-files)
511 (write-region (point-min) (point-max) "charsets.lst"))
512 (kill-emacs))
513
514 ;;;###autoload
515 (defun dump-coding-systems ()
516 (list-coding-systems 'all)
517 (set-buffer (get-buffer "*Help*"))
518 (let (make-backup-files)
519 (write-region (point-min) (point-max) "coding-systems.lst"))
520 (kill-emacs))
521